Evaluate job and jobset in the Eval monad

3 files changed, 25 insertions, 25 deletions

diff --git a/src/Command.hs b/src/Command.hs
index 6fb7e90..6322818 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -11,7 +11,7 @@ module Command (
     getCommonOptions,
     getRootPath, getJobRoot,
     getRepo, getDefaultRepo, tryGetDefaultRepo,
-    getEvalInput,
+    getEvalInput, cmdEvalWith,
     getTerminalOutput,
     getStorageDir,
 ) where
@@ -139,6 +139,10 @@ getEvalInput = CommandExec $ do
     eiOtherRepos <- asks ciOtherRepos
     return EvalInput {..}
 
+cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a
+cmdEvalWith f ev = do
+    either (tfail . textEvalError) return =<< liftIO .runEval ev . f =<< getEvalInput
+
 getTerminalOutput :: CommandExec TerminalOutput
 getTerminalOutput = CommandExec (asks ciTerminalOutput)
 
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 61a4620..0535955 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -136,15 +136,13 @@ argumentJobSource names = do
     cidPart <- case jobsetCommit of
         Just commit -> (: []) . JobIdTree . treeId <$> getCommitTree commit
         Nothing -> return []
-    einputBase <- getEvalInput
-    let einput = einputBase
-            { eiCurrentIdRev = cidPart ++ eiCurrentIdRev einputBase
-            }
     jobsetJobsEither <- fmap Right $ forM names $ \name ->
         case find ((name ==) . jobName) (configJobs config) of
             Just job -> return job
             Nothing -> tfail $ "job `" <> textJobName name <> "' not found"
-    oneshotJobSource [ evalJobSet einput JobSet {..} ]
+    oneshotJobSource . (: []) =<<
+        cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei })
+        (evalJobSet JobSet {..})
 
 loadJobSetFromRoot :: (MonadIO m, MonadFail m) => JobRoot -> Commit -> m DeclaredJobSet
 loadJobSetFromRoot root commit = case root of
@@ -158,14 +156,12 @@ rangeSource :: Text -> Text -> CommandExec JobSource
 rangeSource base tip = do
     root <- getJobRoot
     repo <- getDefaultRepo
-    einputBase <- getEvalInput
     commits <- listCommits repo (base <> ".." <> tip)
     jobsets <- forM commits $ \commit -> do
         tree <- getCommitTree commit
-        let einput = einputBase
-                { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev einputBase
-                }
-        evalJobSet einput <$> loadJobSetFromRoot root commit
+        cmdEvalWith (\ei -> ei
+            { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev ei
+            }) . evalJobSet =<< loadJobSetFromRoot root commit
     oneshotJobSource jobsets
 
 
@@ -189,7 +185,8 @@ watchBranchSource branch = do
                 let einput = einputBase
                         { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev einputBase
                         }
-                evalJobSet einput <$> loadJobSetFromRoot root commit
+                either (fail . T.unpack . textEvalError) return =<<
+                    flip runEval einput . evalJobSet =<< loadJobSetFromRoot root commit
             nextvar <- newEmptyTMVarIO
             atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar )
             go cur nextvar
@@ -218,7 +215,8 @@ watchTagSource pat = do
                 let einput = einputBase
                         { eiCurrentIdRev = JobIdTree (treeId tree) : eiCurrentIdRev einputBase
                         }
-                jobset <- evalJobSet einput <$> (loadJobSetFromRoot root) (tagObject tag)
+                jobset <- either (fail . T.unpack . textEvalError) return =<<
+                    flip runEval einput . evalJobSet =<< loadJobSetFromRoot root (tagObject tag)
                 nextvar <- newEmptyTMVarIO
                 atomically $ putTMVar tmvar $ Just ( [ jobset ], JobSource nextvar )
                 go nextvar
diff --git a/src/Eval.hs b/src/Eval.hs
index 0e3e3e0..1278c6f 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -12,7 +12,6 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 
-import Data.Bifunctor
 import Data.List
 import Data.Maybe
 import Data.Text (Text)
@@ -43,8 +42,9 @@ runEval :: Eval a -> EvalInput -> IO (Either EvalError a)
 runEval action einput = runExceptT $ flip runReaderT einput action
 
 
-evalJob :: EvalInput -> DeclaredJob -> Except EvalError Job
-evalJob EvalInput {..} decl = do
+evalJob :: DeclaredJob -> Eval Job
+evalJob decl = do
+    EvalInput {..} <- ask
     otherCheckout <- forM (jobOtherCheckout decl) $ \( name, revision, checkout ) -> do
         repo <- maybe (throwError $ OtherEvalError $ "repo `" <> textRepoName name <> "' not defined") return $
             lookup name eiOtherRepos
@@ -59,25 +59,23 @@ evalJob EvalInput {..} decl = do
         , jobUses = jobUses decl
         }
 
-evalJobSet :: EvalInput -> DeclaredJobSet -> JobSet
-evalJobSet ei decl = do
-    JobSet
+evalJobSet :: DeclaredJobSet -> Eval JobSet
+evalJobSet decl = do
+    jobs <- either (return . Left) (handleToEither . mapM evalJob) $ jobsetJobsEither decl
+    return JobSet
         { jobsetCommit = jobsetCommit decl
-        , jobsetJobsEither = join $
-            fmap (sequence . map (runExceptStr . evalJob ei)) $
-            jobsetJobsEither decl
+        , jobsetJobsEither = jobs
         }
   where
-    runExceptStr = first (T.unpack . textEvalError) . runExcept
+    handleToEither = handleError (return . Left . T.unpack . textEvalError) . fmap Right
 
 
 canonicalJobName :: [ Text ] -> Maybe Tree -> Config -> Eval [ JobIdPart ]
 canonicalJobName (r : rs) mbTree config = do
-    einput <- ask
     let name = JobName r
     case find ((name ==) . jobName) (configJobs config) of
         Just djob -> do
-            job <- either throwError return $ runExcept $ evalJob einput djob
+            job <- evalJob djob
             repos <- concat <$> sequence
                 [ case mbTree of
                     Just _ -> return []