Rename Expression module to Range

1 files changed, 357 insertions, 0 deletions

diff --git a/src/Range.hs b/src/Range.hs
new file mode 100644
index 0000000..ad99db8
--- /dev/null
+++ b/src/Range.hs
@@ -0,0 +1,357 @@
+module Range (
+    DeclaredRef(..),
+    StaticRef',
+    WatchedRef(..),
+    WatchedRef',
+
+    RevisionExpression'(..), RevisionExpression, DeclaredRevisionExpression,
+    RangeExpression'(..), RangeExpression, DeclaredRangeExpression,
+    CommitRange(..),
+    evaluateDeclaredRevision, evaluateDeclaredRange,
+    evaluateRevision, evaluateRange,
+    getCommitFromRef,
+    getRangeCommits, getAddedRangeCommits,
+
+    isRangeExpressionDynamic,
+    isRevisionExpressionDynamic,
+
+    parseRangeExpression,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Data.Bifunctor
+import Data.Char
+import Data.Function
+import Data.Kind
+import Data.List
+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.Time.LocalTime
+import Data.Void
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+import System.FilePath.Glob as Glob
+import System.IO.Error
+
+import Job.Types
+import Output
+import Repo
+
+
+data DeclaredRef
+    = TextRef Text
+    | UpstreamRef Text
+    | TagRef Pattern (Tag Commit -> Tag Commit -> Tag Commit)
+
+type family StaticRef' d :: Type where
+    StaticRef' Declared = DeclaredRef
+    StaticRef' Evaluated = Commit
+
+data WatchedRef
+    = BranchRef (STM (Maybe Commit))
+    | WatchedTagRef (WatchedTags (Tag Commit))
+
+type family WatchedRef' d :: Type where
+    WatchedRef' Declared = DeclaredRef
+    WatchedRef' Evaluated = WatchedRef
+
+
+type family StaticTags' d :: Type where
+    StaticTags' Declared = Pattern
+    StaticTags' Evaluated = [ Tag Commit ]
+
+data WatchedTags a = WatchedTags
+    { wtPattern :: Pattern
+    , wtUpdate :: Tag Commit -> a -> a
+    , wtValue :: TVar a
+    , wtChan :: TChan (Tag Commit)
+    }
+
+data TagPattern = TagPattern
+    { tpPattern :: Pattern
+    , tpOnlyNew :: Bool
+    }
+
+type family WatchedTags' d :: Type where
+    WatchedTags' Declared = TagPattern
+    WatchedTags' Evaluated = WatchedTags [ Tag Commit ]
+
+
+data RevisionExpression' d
+    = StaticRef (StaticRef' d)
+    | WatchedRef (WatchedRef' d)
+    | ModifiedRevision Text (RevisionExpression' d)
+
+type RevisionExpression = RevisionExpression' Evaluated
+type DeclaredRevisionExpression = RevisionExpression' Declared
+
+watchedRevision :: DeclaredRevisionExpression -> DeclaredRevisionExpression
+watchedRevision = \case
+    StaticRef r -> WatchedRef r
+    WatchedRef r -> WatchedRef r
+    ModifiedRevision m r -> ModifiedRevision m (watchedRevision r)
+
+
+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
+
+watchedRange :: DeclaredRangeExpression -> DeclaredRangeExpression
+watchedRange = \case
+    SingleRevisionExpression rev -> SingleRevisionExpression (watchedRevision rev)
+    RangeExpression r1 r2 -> RangeExpression (watchedRevision r1) (watchedRevision r2)
+    StaticTagsExpression pat -> WatchedTagsExpression TagPattern { tpOnlyNew = False, tpPattern = pat }
+    WatchedTagsExpression pat -> WatchedTagsExpression pat
+
+
+data CommitRef = CommitRef Text {- suffix -} CommitId
+    deriving (Eq)
+
+data CommitRange
+    = EmptyCommitRange
+    | CommitRange CommitRef {- tip -} CommitRef {- except -}
+    | CommitSet [ CommitRef ]
+    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 (TextRef ref) -> StaticRef <$> readCommit repo ref
+    StaticRef (UpstreamRef ref) ->
+        findUpstreamRef repo ref >>= \case
+            Just uref -> evaluateDeclaredRevision repo $ StaticRef (TextRef uref)
+            Nothing -> fail $ "no upstream ref found for ‘" <> T.unpack ref <> "’ in ‘" <> show repo <> "’"
+    StaticRef (TagRef pat sel) -> do
+        filter (Glob.match pat . T.unpack . tagTag) <$> listTags repo >>= \case
+            [] -> fail $ "no tag matching " <> show (decompile pat) <> " found"
+            ts -> return $ StaticRef $ tagObject $ foldl1' sel ts
+
+    WatchedRef (TextRef ref) -> do
+        watchBranch repo ref >>= \case
+            Right watched -> do
+                output <- getOutput
+                outputEvent output $ TestMessage $ "watch-branch-started " <> ref
+                return $ WatchedRef $ BranchRef watched
+            Left commit -> do
+                return $ StaticRef commit
+
+    WatchedRef (UpstreamRef ref) ->
+        findUpstreamRef repo ref >>= \case
+            Just uref -> evaluateDeclaredRevision repo $ WatchedRef (TextRef uref)
+            Nothing -> fail $ "no upstream ref found for ‘" <> T.unpack ref <> "’ in ‘" <> show repo <> "’"
+
+    WatchedRef (TagRef wtPattern wtUpdate) -> do
+        wtChan <- watchTags repo
+        value <- filter (Glob.match wtPattern . T.unpack . tagTag) <$> listTags repo >>= \case
+            [] -> fail $ "no tag matching " <> show (decompile wtPattern) <> " found"
+            ts -> return $ foldl1' wtUpdate ts
+        wtValue <- liftIO $ newTVarIO value
+        return $ WatchedRef $ WatchedTagRef WatchedTags {..}
+
+    ModifiedRevision suffix rev -> ModifiedRevision suffix <$> evaluateDeclaredRevision repo rev
+
+evaluateDeclaredRange :: (MonadIO m, MonadFail m, MonadOutput m) => Repo -> DeclaredRangeExpression -> m RangeExpression
+evaluateDeclaredRange repo = \case
+    SingleRevisionExpression a ->
+        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 TagPattern {..} -> do
+        let wtPattern = tpPattern
+        wtChan <- watchTags repo
+        value <- if tpOnlyNew
+            then return []
+            else filter (Glob.match wtPattern . T.unpack . tagTag) <$> listTags repo
+        wtValue <- liftIO $ newTVarIO value
+        let wtUpdate = (:)
+        output <- getOutput
+        outputEvent output $ TestMessage $ "watch-tags-started " <> T.pack (decompile wtPattern)
+        return $ WatchedTagsExpression WatchedTags {..}
+
+evaluateRevision :: RevisionExpression -> STM (Maybe CommitRef)
+evaluateRevision = \case
+    StaticRef commit -> return $ Just $ CommitRef "" $ commitId commit
+    WatchedRef (BranchRef getter) -> fmap (CommitRef "" . commitId) <$> getter
+    WatchedRef (WatchedTagRef wt) -> Just . CommitRef "" . commitId . tagObject <$> updateWatchedTags wt
+    ModifiedRevision suffix rev ->
+        fmap (\(CommitRef suffix' ref) -> CommitRef (suffix' <> suffix) ref) <$> evaluateRevision rev
+
+evaluateRange :: RangeExpression -> STM CommitRange
+evaluateRange = \case
+    SingleRevisionExpression revExpr -> do
+        rev <- evaluateRevision revExpr
+        return $ fromMaybe EmptyCommitRange $ CommitSet . (: []) <$> rev
+    RangeExpression tipExpr exceptExpr -> do
+        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
+
+getCommitFromRef :: MonadIO m => Repo -> CommitRef -> m (Maybe Commit)
+getCommitFromRef repo = liftIO . tryReadCommit repo . textCommitRef
+
+getCommitIdFromRef :: MonadIO m => Repo -> CommitRef -> m (Maybe CommitId)
+getCommitIdFromRef repo = fmap (fmap commitId) . getCommitFromRef repo
+
+getRangeCommits :: MonadIO m => Repo -> CommitRange -> m [ Commit ]
+getRangeCommits repo = \case
+    EmptyCommitRange -> do
+        return []
+    CommitRange tip except -> do
+        tipId <- getCommitIdFromRef repo tip
+        excId <- getCommitIdFromRef repo except
+        listCommitsFrom repo (catMaybes [ tipId ]) (catMaybes [ excId ])
+    CommitSet refs -> do
+        return . catMaybes . map (either (const Nothing) Just) =<<
+            mapM (liftIO . tryIOError . readCommitId repo) . catMaybes =<<
+                mapM (getCommitIdFromRef repo) refs
+
+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'
+getAddedRangeCommits repo prev cur = do
+    prevList <- getRangeCommits repo prev
+    curList <- getRangeCommits repo cur
+    return $ filter (not . (`elem` prevList)) curList
+
+
+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
+    StaticRef _ -> False
+    WatchedRef _ -> True
+    ModifiedRevision _ e -> isRevisionExpressionDynamic e
+
+updateWatchedTags :: WatchedTags a -> STM a
+updateWatchedTags wt@WatchedTags {..} = do
+    tryReadTChan wtChan >>= \case
+        Nothing -> readTVar wtValue
+        Just tag -> do
+            when (Glob.match wtPattern $ T.unpack $ tagTag tag) $ do
+                writeTVar wtValue . (wtUpdate tag) =<< readTVar wtValue
+            updateWatchedTags wt
+
+
+type RangeParser = Parsec Void Text
+
+parseRangeExpression :: Text -> Either String DeclaredRangeExpression
+parseRangeExpression = bimap errorBundlePretty id . runParser parser ""
+  where
+    parser :: RangeParser DeclaredRangeExpression
+    parser = do
+        range <- parseRange
+        eof
+        return range
+
+    parseRange :: RangeParser DeclaredRangeExpression
+    parseRange = do
+        range <- parseRevision
+        choice
+          [ do
+              SingleRevisionExpression rev1 <- return range
+              _ <- string ".."
+              SingleRevisionExpression rev2 <- parseRevision
+              return $ RangeExpression rev2 rev1
+          , do
+              return range
+          ]
+
+    parseTextRef :: RangeParser Text
+    parseTextRef = do
+        fmap T.concat $ some $ choice
+            [ takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/' ])
+            , try $ string "." <* notFollowedBy (char '.')
+            ]
+
+    parseRevision :: RangeParser DeclaredRangeExpression
+    parseRevision = do
+        tok <- parseTextRef
+
+        range <- choice
+            [ between (char '(') (char ')') $ do
+                case tok of
+                    "watch" -> watchedRange <$> parseRange
+                    "tags" -> StaticTagsExpression <$> parseTagPattern
+                    "newtags" -> do
+                        tpPattern <- parseTagPattern
+                        let tpOnlyNew = True
+                        return $ WatchedTagsExpression TagPattern {..}
+                    "highesttag" -> do
+                        pat <- parseTagPattern
+                        return $ SingleRevisionExpression $ StaticRef $ TagRef pat higherTag
+                    "lasttag" -> do
+                        pat <- parseTagPattern
+                        return $ SingleRevisionExpression $ StaticRef $ TagRef pat laterTag
+                    "upstream" -> do
+                        ref <- parseTextRef
+                        return $ SingleRevisionExpression $ StaticRef $ UpstreamRef ref
+                    _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok
+
+            , do
+                return $ SingleRevisionExpression $ StaticRef $ TextRef tok
+            ]
+
+        choice
+            [ do
+                SingleRevisionExpression rev <- return range
+                suffix <- takeWhile1P Nothing (\x -> isNumber x || x `elem` [ '~', '^', '@', '{', '}' ])
+                return $ SingleRevisionExpression $ ModifiedRevision suffix rev
+            , do
+                return range
+            ]
+
+    parseTagPattern = compile . T.unpack <$> takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '.', '[', ']', '*', '?' ])
+
+
+higherTag :: Tag a -> Tag a -> Tag a
+higherTag t t'
+    | components t < components t' = t'
+    | otherwise                    = t
+  where
+    components = map component . T.groupBy ((==) `on` isDigit) . tagTag
+    component s
+        | Just ( c, _ ) <- T.uncons s, isDigit c
+        = Left $ read @Integer $ T.unpack s
+        | otherwise
+        = Right s
+
+laterTag :: Tag a -> Tag a -> Tag a
+laterTag t t'
+    | zonedTimeToUTC (tagTime t) < zonedTimeToUTC (tagTime t') = t'
+    | otherwise                                                = t