1 files changed, 188 insertions, 0 deletions
diff --git a/src/Expression.hs b/src/Expression.hs
new file mode 100644
index 0000000..95ba815
--- /dev/null
+++ b/src/Expression.hs
@@ -0,0 +1,188 @@
+module Expression (
+    StaticRef',
+    WatchedRef(..),
+    WatchedRef',
+
+    RevisionExpression'(..), RevisionExpression, DeclaredRevisionExpression,
+    RangeExpression'(..), RangeExpression, DeclaredRangeExpression,
+    CommitRange(..),
+    evaluateDeclaredRevision, evaluateDeclaredRange,
+    evaluateRevision, evaluateRange,
+    getRangeCommits, getAddedRangeCommits,
+
+    isRangeExpressionDynamic,
+    isRevisionExpressionDynamic,
+
+    parseRangeExpression,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class
+
+import Data.Bifunctor
+import Data.Char
+import Data.Kind
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe
+import Data.Proxy
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Void
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+import Job.Types
+import Output
+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, MonadOutput m) => Repo -> DeclaredRevisionExpression -> m RevisionExpression
+evaluateDeclaredRevision repo = \case
+    StaticRef ref -> StaticRef <$> readCommit repo ref
+    WatchedRef ref -> do
+        watched <- watchBranch repo ref
+        output <- getOutput
+        outputEvent output $ TestMessage $ "watch-branch-started " <> ref
+        return $ WatchedRef $ BranchRef watched
+    ModifiedRevision suffix rev -> ModifiedRevision suffix <$> evaluateDeclaredRevision repo rev
+
+evaluateDeclaredRange :: (MonadIO m, MonadFail m, MonadOutput 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'
+
+
+isRangeExpressionDynamic :: RangeExpression -> Bool
+isRangeExpressionDynamic = \case
+    RangeExpression x y -> isRevisionExpressionDynamic x || isRevisionExpressionDynamic y
+
+isRevisionExpressionDynamic :: RevisionExpression -> Bool
+isRevisionExpressionDynamic = \case
+    StaticRef _ -> False
+    WatchedRef _ -> True
+    ModifiedRevision _ e -> isRevisionExpressionDynamic e
+
+
+type ExprParser = Parsec Void Text
+
+parseRangeExpression :: Text -> Either String DeclaredRangeExpression
+parseRangeExpression = bimap errorBundlePretty id . runParser parser ""
+  where
+    parser :: ExprParser DeclaredRangeExpression
+    parser = do
+        rev1 <- parseRevision
+        expr <- choice
+          [ do
+              _ <- string ".."
+              rev2 <- parseRevision
+              return $ RangeExpression rev2 rev1
+          , do
+              return $ RangeExpression rev1 (ModifiedRevision "^" rev1)
+          ]
+
+        (char ':' >> eof) <|> eof
+        return expr
+
+    parseRevision :: ExprParser DeclaredRevisionExpression
+    parseRevision = do
+        tok <- fmap T.concat $ some $ choice
+            [ takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/' ])
+            , try $ string "." <* notFollowedBy (char '.')
+            ]
+
+        rev <- choice
+            [ do
+                _ <- char '('
+                arg <- takeWhileP Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/', '.' ])
+                _ <- char ')'
+                case tok of
+                    "watch" -> return $ WatchedRef arg
+                    _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok
+
+            , do
+                return $ StaticRef tok
+            ]
+
+        choice
+            [ do
+                suffix <- takeWhile1P Nothing (\x -> isNumber x || x `elem` [ '~', '^', '@', '{', '}' ])
+                return $ ModifiedRevision suffix rev
+            , do
+                return rev
+            ]