diff options
| -rw-r--r-- | src/Command.hs | 6 | ||||
| -rw-r--r-- | src/Command/Run.hs | 22 | ||||
| -rw-r--r-- | src/Eval.hs | 22 |
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 [] |