diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Error.hs | 26 | ||||
| -rw-r--r-- | src/Main.hs | 9 | ||||
| -rw-r--r-- | src/Network.hs | 4 | ||||
| -rw-r--r-- | src/Run.hs | 7 |
4 files changed, 38 insertions, 8 deletions
diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 0000000..5226912 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,26 @@ +module Error ( + TesterError(..), + throwOtherError +) where + +import Control.Exception +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Text (Text) +import Data.Text qualified as T + + +data TesterError + = OtherTesterError Text + +instance Show TesterError where + show = displayException + +instance Exception TesterError where + displayException = \case + OtherTesterError err -> T.unpack err + + +throwOtherError :: (MonadIO m, MonadError IOException m) => Text -> m a +throwOtherError = liftIO . throwIO . OtherTesterError diff --git a/src/Main.hs b/src/Main.hs index aada687..8e89f7c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,6 +20,7 @@ import System.Posix.Terminal import System.Posix.Types import Config +import Error import JUnit import Output import Parser.Core @@ -180,14 +181,14 @@ main = do -> case conftool of ToolPath cpath -> return $ ToolPath $ baseDir </> cpath ToolCabal ccabal -> return $ ToolCabal ccabal - | otherwise -> fail "no test tool defined" + | otherwise -> throwOtherError "no test tool defined" case defaultTool of ToolPath tpath -> case words tpath of (path : _) -> getPermissions path >>= \perms -> do when (not $ executable perms) $ do - fail $ "‘" <> path <> "’ is not executable" - _ -> fail $ "invalid tool argument: ‘" <> tpath <> "’" + throwOtherError $ "‘" <> T.pack path <> "’ is not executable" + _ -> throwOtherError $ "invalid tool argument: ‘" <> T.pack tpath <> "’" ToolCabal _ -> return () files <- if not (null ofiles) @@ -197,7 +198,7 @@ main = do (path, _) -> (path, Nothing) else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config - when (null files) $ fail $ "No test files" + when (null files) $ throwOtherError $ "no test files" useColor <- case optColor opts of Just use -> return use diff --git a/src/Network.hs b/src/Network.hs index b48a233..a06dc9b 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -29,6 +29,8 @@ import Network.Ip import Script.Expr import Script.Expr.Class +import Error + {- NETWORK STRUCTURE ================= @@ -193,7 +195,7 @@ newNode nodeNetwork vname = atomicallyWithIO $ do postpone $ do exists <- doesPathExist nodeDir - when exists $ ioError $ userError $ nodeDir ++ " exists" + when exists $ throwOtherError $ "node directory ‘" <> T.pack nodeDir <> "’ already exists" createDirectoryIfMissing True nodeDir let node = Node {..} @@ -44,6 +44,7 @@ import System.Posix.Signals import System.Process import Config +import Error import GDB import Network import Network.Ip @@ -117,7 +118,7 @@ runTest out opts gdefs test = do when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e exists <- doesPathExist testDir - when exists $ ioError $ userError $ testDir ++ " exists" + when exists $ throwOtherError $ "test directory ‘" <> T.pack testDir <> "’ already exists" createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing @@ -136,12 +137,12 @@ runTest out opts gdefs test = do let path = takeWhile (/= '\n') cabalOut return $ T.unpack $ T.unwords (T.pack path : args) _ -> do - ioError $ userError $ "failed to find ‘" <> T.unpack name <> "’ executable path using cabal" + throwOtherError $ "failed to find ‘" <> name <> "’ executable path using cabal" | otherwise -> return $ T.unpack arg defaultTool <- case optDefaultTool opts of Just tool -> evalTool tool - Nothing -> ioError $ userError "No test tool defined" + Nothing -> throwOtherError "no test tool defined" procTools <- mapM (sequence . fmap evalTool) $ optProcTools opts mgdb <- if optGDB opts |