Tags watch expressions

2 files changed, 58 insertions, 6 deletions

diff --git a/src/Expression.hs b/src/Expression.hs
index 4ff7ddd..536bf68 100644
--- a/src/Expression.hs
+++ b/src/Expression.hs
@@ -17,6 +17,7 @@ module Expression (
 ) where
 
 import Control.Concurrent.STM
+import Control.Monad
 import Control.Monad.IO.Class
 
 import Data.Bifunctor
@@ -32,6 +33,7 @@ import Data.Void
 import Text.Megaparsec
 import Text.Megaparsec.Char
 
+import System.FilePath.Glob as Glob
 import System.IO.Error
 
 import Job.Types
@@ -51,6 +53,21 @@ type family WatchedRef' d :: Type where
     WatchedRef' Evaluated = WatchedRef
 
 
+type family StaticTags' d :: Type where
+    StaticTags' Declared = Pattern
+    StaticTags' Evaluated = [ Tag Commit ]
+
+data WatchedTags = WatchedTags
+    { wtPattern :: Pattern
+    , wtList :: TVar [ Tag Commit ]
+    , wtChan :: TChan (Tag Commit)
+    }
+
+type family WatchedTags' d :: Type where
+    WatchedTags' Declared = Pattern
+    WatchedTags' Evaluated = WatchedTags
+
+
 data RevisionExpression' d
     = StaticRef (StaticRef' d)
     | WatchedRef (WatchedRef' d)
@@ -69,6 +86,8 @@ watchedRevision = \case
 data RangeExpression' d
     = SingleRevisionExpression (RevisionExpression' d)
     | RangeExpression (RevisionExpression' d) {- tip -} (RevisionExpression' d) {- except -}
+    | StaticTagsExpression (StaticTags' d)
+    | WatchedTagsExpression (WatchedTags' d)
 
 type RangeExpression = RangeExpression' Evaluated
 type DeclaredRangeExpression = RangeExpression' Declared
@@ -77,6 +96,8 @@ watchedRange :: DeclaredRangeExpression -> DeclaredRangeExpression
 watchedRange = \case
     SingleRevisionExpression rev -> SingleRevisionExpression (watchedRevision rev)
     RangeExpression r1 r2 -> RangeExpression (watchedRevision r1) (watchedRevision r2)
+    StaticTagsExpression pat -> WatchedTagsExpression pat
+    WatchedTagsExpression pat -> WatchedTagsExpression pat
 
 
 data CommitRef = CommitRef Text {- suffix -} CommitId
@@ -85,7 +106,7 @@ data CommitRef = CommitRef Text {- suffix -} CommitId
 data CommitRange
     = EmptyCommitRange
     | CommitRange CommitRef {- tip -} CommitRef {- except -}
-    | CommitSet [ CommitRef ] {- latest first -}
+    | CommitSet [ CommitRef ]
     deriving (Eq)
 
 textCommitRef :: CommitRef -> Text
@@ -108,6 +129,12 @@ evaluateDeclaredRange repo = \case
         SingleRevisionExpression <$> evaluateDeclaredRevision repo a
     RangeExpression a b ->
         RangeExpression <$> evaluateDeclaredRevision repo a <*> evaluateDeclaredRevision repo b
+    StaticTagsExpression pat ->
+        StaticTagsExpression . filter (Glob.match pat . T.unpack . tagTag) <$> listTags repo
+    WatchedTagsExpression wtPattern -> do
+        wtChan <- watchTags repo
+        wtList <- liftIO . newTVarIO . filter (Glob.match wtPattern . T.unpack . tagTag) =<< listTags repo
+        return $ WatchedTagsExpression WatchedTags {..}
 
 evaluateRevision :: RevisionExpression -> STM (Maybe CommitRef)
 evaluateRevision = \case
@@ -125,6 +152,10 @@ evaluateRange = \case
         tip <- evaluateRevision tipExpr
         except <- evaluateRevision exceptExpr
         return $ fromMaybe EmptyCommitRange $ CommitRange <$> tip <*> except
+    StaticTagsExpression tags -> do
+        return $ CommitSet $ map (CommitRef "" . commitId . tagObject) tags
+    WatchedTagsExpression wt -> do
+        CommitSet . map (CommitRef "" . commitId . tagObject) <$> updateWatchedTags wt
 
 getCommitIdFromRef :: MonadIO m => Repo -> CommitRef -> m (Maybe CommitId)
 getCommitIdFromRef repo = liftIO . fmap (fmap commitId) . tryReadCommit repo . textCommitRef
@@ -164,6 +195,8 @@ isRangeExpressionDynamic :: RangeExpression -> Bool
 isRangeExpressionDynamic = \case
     SingleRevisionExpression x -> isRevisionExpressionDynamic x
     RangeExpression x y -> isRevisionExpressionDynamic x || isRevisionExpressionDynamic y
+    StaticTagsExpression {} -> False
+    WatchedTagsExpression {} -> True
 
 isRevisionExpressionDynamic :: RevisionExpression -> Bool
 isRevisionExpressionDynamic = \case
@@ -171,6 +204,15 @@ isRevisionExpressionDynamic = \case
     WatchedRef _ -> True
     ModifiedRevision _ e -> isRevisionExpressionDynamic e
 
+updateWatchedTags :: WatchedTags -> STM [ Tag Commit ]
+updateWatchedTags wt@WatchedTags {..} = do
+    tryReadTChan wtChan >>= \case
+        Nothing -> readTVar wtList
+        Just tag -> do
+            when (Glob.match wtPattern $ T.unpack $ tagTag tag) $ do
+                writeTVar wtList . (tag :) =<< readTVar wtList
+            updateWatchedTags wt
+
 
 type ExprParser = Parsec Void Text
 
@@ -204,12 +246,11 @@ parseRangeExpression = bimap errorBundlePretty id . runParser parser ""
             ]
 
         range <- choice
-            [ do
-                _ <- char '('
-                arg <- parseRange
-                _ <- char ')'
+            [ between (char '(') (char ')') $ do
                 case tok of
-                    "watch" -> return $ watchedRange arg
+                    "watch" -> watchedRange <$> parseRange
+                    "tags" -> StaticTagsExpression . compile . T.unpack <$>
+                        takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '.', '[', ']', '*', '?' ])
                     _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok
 
             , do
diff --git a/src/Repo.hs b/src/Repo.hs
index 78d0c60..b6ad8d4 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -16,6 +16,7 @@ module Repo (
     readBranch,
     readTag, tryReadTag,
     listCommits, listCommitsFrom,
+    listTags,
     mergeBase,
     findUpstreamRef,
 
@@ -287,6 +288,16 @@ listCommitsFrom commitRepo from except = liftIO $ do
         commitDetails <- newMVar Nothing
         return Commit {..}
 
+listTags :: MonadIO m => Repo -> m [ Tag Commit ]
+listTags repo = liftIO $ do
+    out <- runGitCommand repo
+        [ "for-each-ref", "refs/tags"
+        , "--format=%(objecttype) %(refname:short)"
+        ]
+    fmap catMaybes $ forM (map words $ lines out) $ \case
+        [ "tag", tname ] -> tryReadTag repo (T.pack tname)
+        _ -> return Nothing
+
 mergeBase :: MonadIO m => Repo -> [ CommitId ] -> m [ Commit ]
 mergeBase commitRepo cids = liftIO $ do
     out <- runGitCommand commitRepo $ "merge-base" : "--all" : "--octopus" : map showCommitId cids