diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Run.hs | 37 | ||||
| -rw-r--r-- | src/Expression.hs | 109 |
2 files changed, 126 insertions, 20 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 39718f2..d4c995f 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -14,15 +14,14 @@ import Data.List import Data.Maybe import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import System.Console.GetOpt import System.FilePath.Glob -import System.IO import Command import Config import Eval +import Expression import Job import Job.Types import Output @@ -221,22 +220,18 @@ rangeSource base tip = do oneshotJobSource jobsets -watchBranchSource :: Text -> CommandExec JobSource -watchBranchSource branch = do +watchExpressionSource :: RangeExpression -> CommandExec JobSource +watchExpressionSource expr = do root <- getJobRoot repo <- getDefaultRepo einputBase <- getEvalInput - output <- getOutput - getCurrentTip <- watchBranch repo branch let go running prev tmvar = do cur <- atomically $ do - getCurrentTip >>= \case - Just cur -> do - when (cur == prev) retry - return cur - Nothing -> retry + cur <- evaluateRange expr + when (cur == prev) retry + return cur - commits <- listCommits repo (textCommitId (commitId prev) <> ".." <> textCommitId (commitId cur)) + commits <- getAddedRangeCommits repo prev cur jobsets <- forM commits $ \commit -> do tree <- getCommitTree commit let einput = einputBase @@ -247,7 +242,7 @@ watchBranchSource branch = do jsiCancelAction <- Just <$> newEmptyMVar return JobSourceItem {..} - obsolete <- listCommits repo (textCommitId (commitId cur) <> ".." <> textCommitId (commitId prev)) + obsolete <- getAddedRangeCommits repo cur prev obsoleteIds <- forM obsolete $ \commit -> do tree <- getCommitTree commit return $ JobSetId $ JobIdTree Nothing (treeSubdir tree) (treeId tree) : eiCurrentIdRev einputBase @@ -261,15 +256,17 @@ watchBranchSource branch = do liftIO $ do tmvar <- newEmptyTMVarIO - atomically getCurrentTip >>= \case - Just commit -> do - outputEvent output $ TestMessage $ "watch-branch-started " <> branch - void $ forkIO $ go [] commit tmvar - Nothing -> do - T.hPutStrLn stderr $ "Branch ‘" <> branch <> "’ not found" - atomically $ putTMVar tmvar Nothing + void $ forkIO $ go [] EmptyCommitRange tmvar return $ JobSource tmvar +watchBranchSource :: Text -> CommandExec JobSource +watchBranchSource branch = do + repo <- getDefaultRepo + output <- getOutput + expr <- evaluateDeclaredRange repo $ RangeExpression (WatchedRef branch) (StaticRef branch) + outputEvent output $ TestMessage $ "watch-branch-started " <> branch + watchExpressionSource expr + watchTagSource :: Pattern -> CommandExec JobSource watchTagSource pat = do root <- getJobRoot diff --git a/src/Expression.hs b/src/Expression.hs new file mode 100644 index 0000000..cd6c9dc --- /dev/null +++ b/src/Expression.hs @@ -0,0 +1,109 @@ +module Expression ( + StaticRef', + WatchedRef(..), + WatchedRef', + + RevisionExpression'(..), RevisionExpression, DeclaredRevisionExpression, + RangeExpression'(..), RangeExpression, DeclaredRangeExpression, + CommitRange(..), + evaluateDeclaredRevision, evaluateDeclaredRange, + evaluateRevision, evaluateRange, + getRangeCommits, getAddedRangeCommits, +) where + +import Control.Concurrent.STM +import Control.Monad.IO.Class + +import Data.Kind +import Data.Maybe +import Data.Text (Text) + +import Job.Types +import Repo + + +type family StaticRef' d :: Type where + StaticRef' Declared = Text + StaticRef' Evaluated = Commit + +data WatchedRef + = BranchRef (STM (Maybe Commit)) + +type family WatchedRef' d :: Type where + WatchedRef' Declared = Text + WatchedRef' Evaluated = WatchedRef + + +data RevisionExpression' d + = StaticRef (StaticRef' d) + | WatchedRef (WatchedRef' d) + | ModifiedRevision Text (RevisionExpression' d) + +type RevisionExpression = RevisionExpression' Evaluated +type DeclaredRevisionExpression = RevisionExpression' Declared + + +data RangeExpression' d + = RangeExpression (RevisionExpression' d) {- tip -} (RevisionExpression' d) {- except -} + +type RangeExpression = RangeExpression' Evaluated +type DeclaredRangeExpression = RangeExpression' Declared + + +data CommitRef = CommitRef Text {- suffix -} CommitId + deriving (Eq) + +data CommitRange + = EmptyCommitRange + | CommitRange CommitRef {- tip -} CommitRef {- except -} + deriving (Eq) + +textCommitRef :: CommitRef -> Text +textCommitRef (CommitRef suffix cid) = textCommitId cid <> suffix + + +evaluateDeclaredRevision :: (MonadIO m, MonadFail m) => Repo -> DeclaredRevisionExpression -> m RevisionExpression +evaluateDeclaredRevision repo = \case + StaticRef ref -> StaticRef <$> readCommit repo ref + WatchedRef ref -> WatchedRef . BranchRef <$> watchBranch repo ref + ModifiedRevision suffix rev -> ModifiedRevision suffix <$> evaluateDeclaredRevision repo rev + +evaluateDeclaredRange :: (MonadIO m, MonadFail m) => Repo -> DeclaredRangeExpression -> m RangeExpression +evaluateDeclaredRange repo (RangeExpression a b) = + RangeExpression <$> evaluateDeclaredRevision repo a <*> evaluateDeclaredRevision repo b + +evaluateRevision :: RevisionExpression -> STM (Maybe CommitRef) +evaluateRevision = \case + StaticRef commit -> return $ Just $ CommitRef "" $ commitId commit + WatchedRef (BranchRef getter) -> fmap (CommitRef "" . commitId) <$> getter + ModifiedRevision suffix rev -> + fmap (\(CommitRef suffix' ref) -> CommitRef (suffix' <> suffix) ref) <$> evaluateRevision rev + +evaluateRange :: RangeExpression -> STM CommitRange +evaluateRange (RangeExpression tipExpr exceptExpr) = do + tip <- evaluateRevision tipExpr + except <- evaluateRevision exceptExpr + return $ fromMaybe EmptyCommitRange $ CommitRange <$> tip <*> except + +getCommitIdFromRef :: MonadIO m => Repo -> CommitRef -> m (Maybe CommitId) +getCommitIdFromRef repo = liftIO . fmap (fmap commitId) . tryReadCommit repo . textCommitRef + +getRangeCommits :: MonadIO m => Repo -> CommitRange -> m [ Commit ] +getRangeCommits _ EmptyCommitRange = return [] +getRangeCommits repo (CommitRange tip except) = do + tipId <- getCommitIdFromRef repo tip + excId <- getCommitIdFromRef repo except + listCommitsFrom repo (catMaybes [ tipId ]) (catMaybes [ excId ]) + +getAddedRangeCommits :: MonadIO m => Repo -> CommitRange -> CommitRange -> m [ Commit ] +getAddedRangeCommits _ _ EmptyCommitRange = return [] +getAddedRangeCommits repo EmptyCommitRange r = getRangeCommits repo r +getAddedRangeCommits repo (CommitRange ar br) (CommitRange ar' br') = do + a <- getCommitIdFromRef repo ar + b <- getCommitIdFromRef repo br + a' <- getCommitIdFromRef repo ar' + b' <- getCommitIdFromRef repo br' + a'b <- fmap (map commitId) $ mergeBase repo $ catMaybes [ a', b ] + (++) + <$> listCommitsFrom repo a'b (catMaybes [ b' ]) -- added by moving B to B' + <*> listCommitsFrom repo (catMaybes [ a' ]) (catMaybes [ a, b, b' ]) -- added by moving A to A' |