Evaluate repo definitions

9 files changed, 141 insertions, 41 deletions

diff --git a/minici.cabal b/minici.cabal
index 7c05311..c0e7d00 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -51,6 +51,7 @@ executable minici
         Command.Checkout
         Command.Run
         Config
+        Eval
         Job
         Job.Types
         Paths_minici
diff --git a/src/Command.hs b/src/Command.hs
index c9a77e6..aaaaca1 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -12,6 +12,7 @@ module Command (
     getConfigPath,
     getConfig,
     getRepo, getDefaultRepo, tryGetDefaultRepo,
+    getEvalInput,
     getTerminalOutput,
 ) where
 
@@ -29,6 +30,7 @@ import System.Exit
 import System.IO
 
 import Config
+import Eval
 import Repo
 import Terminal
 
@@ -98,7 +100,8 @@ data CommandInput = CommandInput
     { ciOptions :: CommonOptions
     , ciConfigPath :: Maybe FilePath
     , ciConfig :: Either String Config
-    , ciRepos :: [ ( Maybe RepoName, Repo ) ]
+    , ciContainingRepo :: Maybe Repo
+    , ciOtherRepos :: [ ( RepoName, Repo ) ]
     , ciTerminalOutput :: TerminalOutput
     }
 
@@ -119,7 +122,7 @@ getConfig = do
 
 getRepo :: RepoName -> CommandExec Repo
 getRepo name = do
-    CommandExec (asks (lookup (Just name) . ciRepos)) >>= \case
+    CommandExec (asks (lookup name . ciOtherRepos)) >>= \case
         Just repo -> return repo
         Nothing -> tfail $ "repo `" <> textRepoName name <> "' not declared"
 
@@ -130,7 +133,13 @@ getDefaultRepo = do
         Nothing -> tfail $ "no default repo"
 
 tryGetDefaultRepo :: CommandExec (Maybe Repo)
-tryGetDefaultRepo = CommandExec $ asks (lookup Nothing . ciRepos)
+tryGetDefaultRepo = CommandExec $ asks ciContainingRepo
+
+getEvalInput :: CommandExec EvalInput
+getEvalInput = CommandExec $ do
+    eiContainingRepo <- asks ciContainingRepo
+    eiOtherRepos <- asks ciOtherRepos
+    return EvalInput {..}
 
 getTerminalOutput :: CommandExec TerminalOutput
 getTerminalOutput = CommandExec (asks ciTerminalOutput)
diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
index 397db79..3667e76 100644
--- a/src/Command/Checkout.hs
+++ b/src/Command/Checkout.hs
@@ -15,7 +15,7 @@ import Repo
 data CheckoutCommand = CheckoutCommand CheckoutOptions (Maybe RepoName) (Maybe Text)
 
 data CheckoutOptions = CheckoutOptions
-    { coPath :: Maybe FilePath
+    { coDestination :: Maybe FilePath
     , coSubtree :: Maybe FilePath
     }
 
@@ -31,13 +31,13 @@ instance Command CheckoutCommand where
 
     type CommandOptions CheckoutCommand = CheckoutOptions
     defaultCommandOptions _ = CheckoutOptions
-        { coPath = Nothing
+        { coDestination = Nothing
         , coSubtree = Nothing
         }
 
     commandOptions _ =
-        [ Option [] [ "path" ]
-            (ReqArg (\val opts -> opts { coPath = Just val }) "<path>")
+        [ Option [] [ "dest" ]
+            (ReqArg (\val opts -> opts { coDestination = Just val }) "<path>")
             "destination path"
         , Option [] [ "subtree" ]
             (ReqArg (\val opts -> opts { coSubtree = Just val }) "<path>")
@@ -59,4 +59,4 @@ cmdCheckout (CheckoutCommand CheckoutOptions {..} name mbrev) = do
         Nothing -> return root
         Just subtree -> maybe (fail $ "subtree `" <> subtree <> "' not found in " <> maybe "current worktree" (("revision `" <>) . (<> "'") . T.unpack) mbrev) return =<<
             getSubtree subtree root
-    checkoutAt tree $ maybe "." id coPath
+    checkoutAt tree $ maybe "." id coDestination
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index bd29455..b297ec1 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -6,7 +6,8 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import Control.Monad.Reader
+import Control.Monad.Except
+import Control.Monad.IO.Class
 
 import Data.Either
 import Data.List
@@ -21,6 +22,7 @@ import System.IO
 
 import Command
 import Config
+import Eval
 import Job
 import Repo
 import Terminal
@@ -124,22 +126,25 @@ argumentJobSource :: [ JobName ] -> CommandExec JobSource
 argumentJobSource [] = emptyJobSource
 argumentJobSource names = do
     config <- getConfig
+    einput <- getEvalInput
     jobsetJobsEither <- fmap Right $ forM names $ \name ->
         case find ((name ==) . jobName) (configJobs config) of
             Just job -> return job
             Nothing -> tfail $ "job `" <> textJobName name <> "' not found"
     jobsetCommit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo
-    oneshotJobSource [ JobSet {..} ]
+    oneshotJobSource [ evalJobSet einput JobSet {..} ]
 
 rangeSource :: Text -> Text -> CommandExec JobSource
 rangeSource base tip = do
     repo <- getDefaultRepo
+    einput <- getEvalInput
     commits <- listCommits repo (base <> ".." <> tip)
-    oneshotJobSource =<< mapM loadJobSetForCommit commits
+    oneshotJobSource . map (evalJobSet einput) =<< mapM loadJobSetForCommit commits
 
 watchBranchSource :: Text -> CommandExec JobSource
 watchBranchSource branch = do
     repo <- getDefaultRepo
+    einput <- getEvalInput
     getCurrentTip <- watchBranch repo branch
     let go prev tmvar = do
             cur <- atomically $ do
@@ -150,7 +155,7 @@ watchBranchSource branch = do
                     Nothing -> retry
 
             commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur))
-            jobsets <- mapM loadJobSetForCommit commits
+            jobsets <- map (evalJobSet einput) <$> mapM loadJobSetForCommit commits
             nextvar <- newEmptyTMVarIO
             atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
             go cur nextvar
@@ -168,12 +173,13 @@ watchBranchSource branch = do
 watchTagSource :: Pattern -> CommandExec JobSource
 watchTagSource pat = do
     chan <- watchTags =<< getDefaultRepo
+    einput <- getEvalInput
 
     let go tmvar = do
             tag <- atomically $ readTChan chan
             if match pat $ T.unpack $ tagTag tag
               then do
-                jobset <- loadJobSetForCommit $ tagObject tag
+                jobset <- evalJobSet einput <$> loadJobSetForCommit (tagObject tag)
                 nextvar <- newEmptyTMVarIO
                 atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
                 go nextvar
diff --git a/src/Config.hs b/src/Config.hs
index e9287e4..68db57d 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -12,6 +12,7 @@ import Control.Monad.Combinators
 import Control.Monad.IO.Class
 
 import Data.ByteString.Lazy qualified as BS
+import Data.Either
 import Data.List
 import Data.Map qualified as M
 import Data.Maybe
@@ -33,7 +34,7 @@ configFileName = "minici.yaml"
 
 
 data Config = Config
-    { configJobs :: [ Job ]
+    { configJobs :: [ DeclaredJob ]
     , configRepos :: [ DeclaredRepo ]
     }
 
@@ -67,14 +68,14 @@ instance FromYAML Config where
                     return $ config { configRepos = configRepos config ++ [ repo ] }
             _ -> return config
 
-parseJob :: Text -> Node Pos -> Parser Job
+parseJob :: Text -> Node Pos -> Parser DeclaredJob
 parseJob name node = flip (withMap "Job") node $ \j -> do
     let jobName = JobName name
-    jobCheckout <- choice
+    ( jobContainingCheckout, jobOtherCheckout ) <- partitionEithers <$> choice
         [ parseSingleCheckout =<< j .: "checkout"
         , parseMultipleCheckouts =<< j .: "checkout"
         , withNull "no checkout" (return []) =<< j .: "checkout"
-        , return [ ( Nothing, Nothing ) ]
+        , return [ Left $ JobCheckout Nothing Nothing ]
         ]
     jobRecipe <- choice
         [ cabalJob =<< j .: "cabal"
@@ -84,13 +85,17 @@ parseJob name node = flip (withMap "Job") node $ \j -> do
     jobUses <- maybe (return []) parseUses =<< j .:? "uses"
     return Job {..}
 
-parseSingleCheckout :: Node Pos -> Parser [ ( Maybe RepoName, Maybe FilePath ) ]
+parseSingleCheckout :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
 parseSingleCheckout = withMap "checkout definition" $ \m -> do
-    name <- m .:? "repo"
-    subtree <- m .:? "subtree"
-    return [ ( RepoName <$> name, T.unpack <$> subtree ) ]
-
-parseMultipleCheckouts :: Node Pos -> Parser [ ( Maybe RepoName, Maybe FilePath ) ]
+    mbName <- m .:? "repo"
+    jcSubtree <- fmap T.unpack <$> m .:? "subtree"
+    jcDestination <- fmap T.unpack <$> m .:? "dest"
+    let checkout = JobCheckout {..}
+    return $ (: []) $ case mbName of
+        Nothing -> Left checkout
+        Just name -> Right ( DeclaredJobRepo (RepoName name), checkout )
+
+parseMultipleCheckouts :: Node Pos -> Parser [ Either JobCheckout ( JobRepo Declared, JobCheckout ) ]
 parseMultipleCheckouts = withSeq "checkout definitions" $ fmap concat . mapM parseSingleCheckout
 
 cabalJob :: Node Pos -> Parser [CreateProcess]
@@ -156,7 +161,7 @@ loadConfigForCommit commit = do
         Just content -> either (\_ -> Left $ "failed to parse " <> configFileName) Right $ parseConfig content
         Nothing -> Left $ configFileName <> " not found"
 
-loadJobSetForCommit :: MonadIO m => Commit -> m JobSet
+loadJobSetForCommit :: MonadIO m => Commit -> m DeclaredJobSet
 loadJobSetForCommit commit = toJobSet <$> loadConfigForCommit commit
   where
     toJobSet configEither = JobSet
diff --git a/src/Eval.hs b/src/Eval.hs
new file mode 100644
index 0000000..9130dd3
--- /dev/null
+++ b/src/Eval.hs
@@ -0,0 +1,53 @@
+module Eval (
+    EvalInput(..),
+    EvalError(..), textEvalError,
+
+    evalJob,
+    evalJobSet,
+) where
+
+import Control.Monad.Except
+
+import Data.Bifunctor
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Job.Types
+import Repo
+
+data EvalInput = EvalInput
+    { eiContainingRepo :: Maybe Repo
+    , eiOtherRepos :: [ ( RepoName, Repo ) ]
+    }
+
+data EvalError
+    = OtherEvalError Text
+
+textEvalError :: EvalError -> Text
+textEvalError (OtherEvalError text) = text
+
+evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
+evalJob EvalInput {..} decl = do
+    otherCheckout <- forM (jobOtherCheckout decl) $ \( DeclaredJobRepo name, checkout ) -> do
+        repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
+            lookup name eiOtherRepos
+        return ( EvaluatedJobRepo repo, checkout )
+    return Job
+        { jobName = jobName decl
+        , jobContainingCheckout = jobContainingCheckout decl
+        , jobOtherCheckout = otherCheckout
+        , jobRecipe = jobRecipe decl
+        , jobArtifacts = jobArtifacts decl
+        , jobUses = jobUses decl
+        }
+
+evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet
+evalJobSet ei decl = do
+    JobSet
+        { jobsetCommit = jobsetCommit decl
+        , jobsetJobsEither = join $
+            fmap (sequence . map (runExceptStr . evalJob ei)) $
+            jobsetJobsEither decl
+        }
+  where
+    runExceptStr = first (T.unpack . textEvalError) . runExcept
diff --git a/src/Job.hs b/src/Job.hs
index bd9db0e..1d30489 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -1,6 +1,6 @@
 module Job (
-    Job(..),
-    JobSet(..), jobsetJobs,
+    Job, DeclaredJob, Job'(..),
+    JobSet, DeclaredJobSet, JobSet'(..), jobsetJobs,
     JobOutput(..),
     JobName(..), stringJobName, textJobName,
     ArtifactName(..),
diff --git a/src/Job/Types.hs b/src/Job/Types.hs
index 3f6f1f0..a16ba1d 100644
--- a/src/Job/Types.hs
+++ b/src/Job/Types.hs
@@ -8,14 +8,21 @@ import System.Process
 import Repo
 
 
-data Job = Job
+data Declared
+data Evaluated
+
+data Job' d = Job
     { jobName :: JobName
-    , jobCheckout :: [ ( Maybe RepoName, Maybe FilePath ) ]
+    , jobContainingCheckout :: [ JobCheckout ]
+    , jobOtherCheckout :: [ ( JobRepo d, JobCheckout ) ]
     , jobRecipe :: [ CreateProcess ]
     , jobArtifacts :: [ ( ArtifactName, CreateProcess ) ]
     , jobUses :: [ ( JobName, ArtifactName ) ]
     }
 
+type Job = Job' Evaluated
+type DeclaredJob = Job' Declared
+
 data JobName = JobName Text
     deriving (Eq, Ord, Show)
 
@@ -26,15 +33,28 @@ textJobName :: JobName -> Text
 textJobName (JobName name) = name
 
 
+data JobRepo d where
+    DeclaredJobRepo :: RepoName -> JobRepo Declared
+    EvaluatedJobRepo :: Repo -> JobRepo Evaluated
+
+data JobCheckout = JobCheckout
+    { jcSubtree :: Maybe FilePath
+    , jcDestination :: Maybe FilePath
+    }
+
+
 data ArtifactName = ArtifactName Text
     deriving (Eq, Ord, Show)
 
 
-data JobSet = JobSet
+data JobSet' d = JobSet
     { jobsetCommit :: Maybe Commit
-    , jobsetJobsEither :: Either String [ Job ]
+    , jobsetJobsEither :: Either String [ Job' d ]
     }
 
+type JobSet = JobSet' Evaluated
+type DeclaredJobSet = JobSet' Declared
+
 jobsetJobs :: JobSet -> [ Job ]
 jobsetJobs = either (const []) id . jobsetJobsEither
 
diff --git a/src/Main.hs b/src/Main.hs
index f86bd77..826a96d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -184,18 +184,24 @@ runSomeCommand ciConfigPath ciOptions (SC tproxy) args = do
     let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
     let CommandExec exec = commandExec cmd
 
-    namedRepos <- forM (optRepo ciOptions) $ \decl -> do
-        openRepo (repoPath decl) >>= \case
-            Just repo -> return ( Just (repoName decl), repo )
-            Nothing -> do
-                hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl
-                exitFailure
+    ciContainingRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath
+
+    let openDeclaredRepo decl = do
+            openRepo (repoPath decl) >>= \case
+                Just repo -> return ( repoName decl, repo )
+                Nothing -> do
+                    hPutStrLn stderr $ "Failed to open repo `" <> showRepoName (repoName decl) <> "' at " <> repoPath decl
+                    exitFailure
+
+    cmdlineRepos <- forM (optRepo ciOptions) openDeclaredRepo
+    configRepos <- case ciConfig of
+        Right config -> forM (configRepos config) $ \decl -> do
+            case lookup (repoName decl) cmdlineRepos of
+                Just repo -> return ( repoName decl, repo )
+                Nothing -> openDeclaredRepo decl
+        Left _ -> return []
 
-    defaultRepo <- maybe (return Nothing) (openRepo . takeDirectory) ciConfigPath
-    let ciRepos = concat
-            [ maybe [] (\r -> [ ( Nothing, r ) ]) defaultRepo
-            , namedRepos
-            ]
+    let ciOtherRepos = configRepos ++ cmdlineRepos
 
     ciTerminalOutput <- initTerminalOutput
     flip runReaderT CommandInput {..} exec