Config option to find tool path using cabal

Changelog: Added config file option to find test tool executable via cabal.

5 files changed, 64 insertions, 18 deletions

diff --git a/src/Config.hs b/src/Config.hs
index af2161a..8555540 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,5 +1,6 @@
 module Config (
     Config(..),
+    ConfigTool(..),
     findConfig,
     parseConfig,
     getConfigTestFiles,
@@ -20,7 +21,7 @@ import System.FilePath.Glob
 
 data Config = Config
     { configDir :: FilePath
-    , configTool :: Maybe FilePath
+    , configTool :: Maybe ConfigTool
     , configTests :: [ Pattern ]
     , configSelect :: Maybe [ Text ]
     , configExclude :: [ Text ]
@@ -28,9 +29,18 @@ data Config = Config
     }
     deriving (Show)
 
+data ConfigTool
+    = ToolPath FilePath
+    | ToolCabal Text
+    deriving (Show)
+
 instance FromYAML (FilePath -> Config) where
     parseYAML = withMap "Config" $ \m -> do
-        configTool <- (fmap T.unpack <$> m .:? "tool")
+        configTool <- foldr1 (<|>)
+            [ Just . ToolPath . T.unpack <$> m .: "tool" -- tool path as string
+            , Just <$> m .: "tool"
+            , return Nothing
+            ]
         configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)
                 [ fmap (:[]) (m .: "tests") -- single pattern
                 , m .:? "tests" .!= []      -- list of patterns
@@ -55,6 +65,12 @@ instance FromYAML Number where
         Scalar _ (SInt x) -> return $ Number $ fromIntegral x
         node -> typeMismatch "int or float" node
 
+instance FromYAML ConfigTool where
+    parseYAML = withMap "tool specification" $ \m -> foldr1 (<|>)
+        [ ToolPath . T.unpack <$> m .: "path"
+        , ToolCabal <$> m .: "cabal"
+        ]
+
 findConfig :: IO (Maybe FilePath)
 findConfig = go "."
   where
diff --git a/src/Main.hs b/src/Main.hs
index 3bc9e22..fc91b56 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -66,9 +66,9 @@ data TcpdumpOption
 options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
 options =
     [ Option ['T'] ["tool"]
-        (ReqArg (\str -> to $ \opts -> case break (==':') str of
-                                            (path, []) -> opts { optDefaultTool = path }
-                                            (pname, (_:path)) -> opts { optProcTools = (ProcName (T.pack pname), path) : optProcTools opts }
+        (ReqArg (\str -> to $ \opts -> case break (== ':') str of
+                                            ( path, [] ) -> opts { optDefaultTool = ToolPath path }
+                                            ( pname, _ : path ) -> opts { optProcTools = ( ProcName (T.pack pname), ToolPath path ) : optProcTools opts }
                 ) "<path>")
         "test tool to be used"
     , Option ['v'] ["verbose"]
@@ -140,8 +140,14 @@ main = do
     config <- mapM parseConfig =<< findConfig
     let baseDir = maybe "." configDir config
 
-    envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
-        return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
+    envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool -> if
+        | Just envpath <- mbtool
+            -> return $ ToolPath envpath
+        | Just conftool <- configTool =<< config
+            -> case conftool of
+                ToolPath cpath -> return $ ToolPath $ baseDir </> cpath
+                ToolCabal ccabal -> return $ ToolCabal ccabal
+        | otherwise -> return $ error "No test tool defined"
 
     let initOpts = defaultCmdlineOptions
             { optTest = defaultTestOptions
@@ -183,11 +189,13 @@ main = do
         testMode config
         exitSuccess
 
-    case words $ optDefaultTool $ optTest opts of
-        (path : _) -> getPermissions path >>= \perms -> do
-            when (not $ executable perms) $ do
-                fail $ "‘" <> path <> "’ is not executable"
-        _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’"
+    case optDefaultTool $ optTest opts 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 <> "’"
+        ToolCabal _ -> return ()
 
     files <- if not (null ofiles)
         then return $ flip map ofiles $ \ofile ->
diff --git a/src/Run.hs b/src/Run.hs
index 1d637d3..a1184c4 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -126,6 +126,22 @@ runTest out opts gdefs test = do
     procVar <- newMVar []
     timeoutVar <- newMVar ( optTimeout opts, 0 )
 
+    let evalTool = \case
+            ToolPath path -> return path
+            ToolCabal arg
+                | (name : args) <- T.words arg
+                -> do
+                    readCreateProcessWithExitCode (proc "cabal" $ [ "list-bin", T.unpack name ]) "" >>= \case
+                        ( ExitSuccess, cabalOut, _ ) -> 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"
+                | otherwise
+                -> return $ T.unpack arg
+    defaultTool <- evalTool $ optDefaultTool opts
+    procTools <- mapM (sequence . fmap evalTool) $ optProcTools opts
+
     mgdb <- if optGDB opts
         then flip runReaderT out $ do
             gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed
@@ -136,6 +152,8 @@ runTest out opts gdefs test = do
             { teOutput = out
             , teFailed = failedVar
             , teOptions = opts
+            , teDefaultTool = defaultTool
+            , teProcTools = procTools
             , teTestDir = testDir
             , teNextObjId = objIdVar
             , teNextProcId = procIdVar
@@ -344,9 +362,9 @@ runStep = \case
             Right node -> go node
       where
         go node = do
-            opts <- asks $ teOptions . fst
+            env <- asks fst
             let pname = ProcName tname
-                tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
+                tool = fromMaybe (teDefaultTool env) (lookup pname $ teProcTools env)
                 cmd = T.unwords $ T.pack tool : map escape args
                 escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''"
             outProcName OutputChildExec pname cmd
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 8c772d5..d204f09 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -3,6 +3,7 @@ module Run.Monad (
     TestEnv(..),
     TestState(..),
     TestOptions(..), defaultTestOptions,
+    ConfigTool(..),
     Failed(..),
 
     finally,
@@ -24,6 +25,7 @@ import Data.Scientific
 import Data.Set (Set)
 import Data.Text qualified as T
 
+import Config
 import {-# SOURCE #-} GDB
 import Network.Ip
 import Output
@@ -43,6 +45,8 @@ data TestEnv = TestEnv
     { teOutput :: Output
     , teFailed :: TVar (Maybe Failed)
     , teOptions :: TestOptions
+    , teDefaultTool :: FilePath
+    , teProcTools :: [ ( ProcName, FilePath ) ]
     , teTestDir :: FilePath
     , teNextObjId :: MVar Int
     , teNextProcId :: MVar Int
@@ -60,8 +64,8 @@ data TestState = TestState
     }
 
 data TestOptions = TestOptions
-    { optDefaultTool :: String
-    , optProcTools :: [(ProcName, String)]
+    { optDefaultTool :: ConfigTool
+    , optProcTools :: [ ( ProcName, ConfigTool ) ]
     , optTestDir :: FilePath
     , optTimeout :: Scientific
     , optTcpdump :: Maybe FilePath
@@ -76,7 +80,7 @@ data TestOptions = TestOptions
 
 defaultTestOptions :: TestOptions
 defaultTestOptions = TestOptions
-    { optDefaultTool = ""
+    { optDefaultTool = ToolPath ""
     , optProcTools = []
     , optTestDir = ".test"
     , optTimeout = 1
diff --git a/src/TestMode.hs b/src/TestMode.hs
index 2ccf5a4..22481f4 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -84,7 +84,7 @@ runTestsC tests = do
     Just LoadedModules {..} <- gets tmsModules
     mbconfig <- asks tmiConfig
     let opts = defaultTestOptions
-            { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig
+            { optDefaultTool = fromMaybe (ToolPath "/bin/true") $ configTool =<< mbconfig
             , optTestDir = ".test" <> show num
             , optKeep = True
             , optKeepGoing = True