1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
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
]
|