Watch branches using more generic expression structureHEADmaster

3 files changed, 127 insertions, 20 deletions

diff --git a/minici.cabal b/minici.cabal
index 6ae8686..97c6b97 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -58,6 +58,7 @@ executable minici
         Config
         Destination
         Eval
+        Expression
         FileUtils
         Job
         Job.Types
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'