diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Run.hs | 27 | ||||
| -rw-r--r-- | src/Eval.hs | 87 | ||||
| -rw-r--r-- | src/Repo.hs | 10 |
3 files changed, 113 insertions, 11 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index a7e7eff..a80e15d 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -126,7 +126,7 @@ mergeSources sources = do argumentJobSource :: [ JobName ] -> CommandExec JobSource argumentJobSource [] = emptyJobSource argumentJobSource names = do - ( config, jobsetCommit ) <- getJobRoot >>= \case + ( config, jcommit ) <- getJobRoot >>= \case JobRootConfig config -> do commit <- sequence . fmap createWipCommit =<< tryGetDefaultRepo return ( config, commit ) @@ -135,24 +135,33 @@ argumentJobSource names = do config <- either fail return =<< loadConfigForCommit =<< getCommitTree commit return ( config, Just commit ) - jobtree <- case jobsetCommit of + jobtree <- case jcommit of Just commit -> (: []) <$> getCommitTree commit Nothing -> return [] let cidPart = map (JobIdTree Nothing "" . treeId) jobtree - jobsetId = () - jobsetJobsEither <- fmap Right $ forM names $ \name -> + forM_ names $ \name -> case find ((name ==) . jobName) (configJobs config) of - Just job -> return job + Just _ -> return () Nothing -> tfail $ "job ‘" <> textJobName name <> "’ not found" - oneshotJobSource . (: []) =<< - cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) - (evalJobSet (map ( Nothing, ) jobtree) JobSet {..}) + + jset <- cmdEvalWith (\ei -> ei { eiCurrentIdRev = cidPart ++ eiCurrentIdRev ei }) $ do + fullSet <- evalJobSet (map ( Nothing, ) jobtree) JobSet + { jobsetId = () + , jobsetCommit = jcommit + , jobsetJobsEither = Right (configJobs config) + } + let selectedSet = fullSet { jobsetJobsEither = fmap (filter ((`elem` names) . jobName)) (jobsetJobsEither fullSet) } + fillInDependencies selectedSet + oneshotJobSource [ jset ] refJobSource :: [ JobRef ] -> CommandExec JobSource refJobSource [] = emptyJobSource refJobSource refs = do jobs <- foldl' addJobToList [] <$> cmdEvalWith id (mapM evalJobReference refs) - oneshotJobSource . map (\( sid, js ) -> JobSet sid Nothing (Right $ reverse js)) $ jobs + sets <- cmdEvalWith id $ do + forM jobs $ \( sid, js ) -> do + fillInDependencies $ JobSet sid Nothing (Right $ reverse js) + oneshotJobSource sets where addJobToList :: [ ( JobSetId, [ Job ] ) ] -> ( Job, JobSetId ) -> [ ( JobSetId, [ Job ] ) ] addJobToList (( sid, js ) : rest ) ( job, jsid ) diff --git a/src/Eval.hs b/src/Eval.hs index 57a9d88..67fea8d 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -6,6 +6,9 @@ module Eval ( evalJob, evalJobSet, evalJobReference, + + loadJobSetById, + fillInDependencies, ) where import Control.Monad @@ -14,6 +17,7 @@ import Control.Monad.Reader import Data.List import Data.Maybe +import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T @@ -178,3 +182,86 @@ evalJobReference (JobRef rs) = canonicalCommitConfig rs defRepo JobRootConfig config -> do canonicalJobName rs config Nothing + + +jobsetFromConfig :: [ JobIdPart ] -> Config -> Maybe Tree -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) +jobsetFromConfig sid config _ = do + EvalInput {..} <- ask + let dset = JobSet () Nothing $ Right $ configJobs config + otherRepos <- forM sid $ \case + JobIdName name -> do + throwError $ OtherEvalError $ "expected tree id, not a job name ‘" <> textJobName name <> "’" + JobIdCommit name cid -> do + repo <- evalRepo name + tree <- getCommitTree =<< readCommitId repo cid + return ( name, tree ) + JobIdTree name path tid -> do + repo <- evalRepo name + tree <- readTreeId repo path tid + return ( name, tree ) + return ( dset, eiCurrentIdRev, otherRepos ) + +jobsetFromCommitConfig :: [ JobIdPart ] -> Repo -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) +jobsetFromCommitConfig (JobIdTree name path tid : sid) repo = do + when (isJust name) $ do + throwError $ OtherEvalError $ "expected default repo commit or tree id" + when (not (null path)) $ do + throwError $ OtherEvalError $ "expected root commit or tree id" + tree <- readTreeId repo path tid + config <- either fail return =<< loadConfigForCommit tree + local (\ei -> ei { eiCurrentIdRev = JobIdTree Nothing "" (treeId tree) : eiCurrentIdRev ei }) $ do + ( dset, idRev, otherRepos ) <- jobsetFromConfig sid config (Just tree) + return ( dset, idRev, ( Nothing, tree ) : otherRepos ) + +jobsetFromCommitConfig (JobIdCommit name cid : sid) repo = do + when (isJust name) $ do + throwError $ OtherEvalError $ "expected default repo commit or tree id" + tree <- getCommitTree =<< readCommitId repo cid + jobsetFromCommitConfig (JobIdTree name "" (treeId tree) : sid) repo + +jobsetFromCommitConfig (JobIdName name : _) _ = do + throwError $ OtherEvalError $ "expected commit or tree id, not a job name ‘" <> textJobName name <> "’" + +jobsetFromCommitConfig [] _ = do + throwError $ OtherEvalError $ "expected commit or tree id" + +loadJobSetById :: JobSetId -> Eval ( DeclaredJobSet, [ JobIdPart ], [ ( Maybe RepoName, Tree ) ] ) +loadJobSetById (JobSetId sid) = do + asks eiJobRoot >>= \case + JobRootRepo defRepo -> do + jobsetFromCommitConfig sid defRepo + JobRootConfig config -> do + jobsetFromConfig sid config Nothing + +fillInDependencies :: JobSet -> Eval JobSet +fillInDependencies jset = do + ( dset, idRev, otherRepos ) <- local (\ei -> ei { eiCurrentIdRev = [] }) $ do + loadJobSetById (jobsetId jset) + origJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither jset + declJobs <- either (throwError . OtherEvalError . T.pack) return $ jobsetJobsEither dset + deps <- gather declJobs S.empty (map jobName origJobs) + + jobs <- local (\ei -> ei { eiCurrentIdRev = idRev }) $ do + fmap catMaybes $ forM declJobs $ \djob -> if + | Just job <- find ((jobName djob ==) . jobName) origJobs + -> return (Just job) + + | jobName djob `S.member` deps + -> Just . fst <$> evalJob otherRepos dset djob + + | otherwise + -> return Nothing + + return $ jset { jobsetJobsEither = Right jobs } + where + gather djobs cur ( name : rest ) + | name `S.member` cur + = gather djobs cur rest + + | Just djob <- find ((name ==) . jobName) djobs + = gather djobs (S.insert name cur) $ map fst (jobUses djob) ++ rest + + | otherwise + = throwError $ OtherEvalError $ "dependency ‘" <> textJobName name <> "’ not found" + + gather _ cur [] = return cur diff --git a/src/Repo.hs b/src/Repo.hs index b154209..09e577b 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -9,8 +9,8 @@ module Repo ( Tag(..), openRepo, - readCommit, tryReadCommit, - readTree, tryReadTree, + readCommit, readCommitId, tryReadCommit, + readTree, readTreeId, tryReadTree, readBranch, readTag, listCommits, @@ -175,6 +175,9 @@ readCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m Commit readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit repo ref where err = "revision ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’" +readCommitId :: (MonadIO m, MonadFail m) => Repo -> CommitId -> m Commit +readCommitId repo cid = readCommit repo (textCommitId cid) + tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit) tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref @@ -182,6 +185,9 @@ readTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m Tree readTree repo@GitRepo {..} subdir ref = maybe (fail err) return =<< tryReadTree repo subdir ref where err = "tree ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’" +readTreeId :: (MonadIO m, MonadFail m) => Repo -> FilePath -> TreeId -> m Tree +readTreeId repo subdir tid = readTree repo subdir $ textTreeId tid + tryReadTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m (Maybe Tree) tryReadTree treeRepo treeSubdir ref = do fmap (fmap TreeId) (tryReadObjectId treeRepo "tree" ref) >>= \case |