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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
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 System.IO.Error
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
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 -}
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)
data CommitRef = CommitRef Text {- suffix -} CommitId
deriving (Eq)
data CommitRange
= EmptyCommitRange
| CommitRange CommitRef {- tip -} CommitRef {- except -}
| CommitSet [ CommitRef ] {- latest first -}
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 = \case
SingleRevisionExpression a ->
SingleRevisionExpression <$> evaluateDeclaredRevision repo a
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 = \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
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 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
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
range <- parseRange
eof
return range
parseRange :: ExprParser DeclaredRangeExpression
parseRange = do
range <- parseRevision
choice
[ do
SingleRevisionExpression rev1 <- return range
_ <- string ".."
SingleRevisionExpression rev2 <- parseRevision
return $ RangeExpression rev2 rev1
, do
return range
]
parseRevision :: ExprParser DeclaredRangeExpression
parseRevision = do
tok <- fmap T.concat $ some $ choice
[ takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/' ])
, try $ string "." <* notFollowedBy (char '.')
]
range <- choice
[ do
_ <- char '('
arg <- parseRange
_ <- char ')'
case tok of
"watch" -> return $ watchedRange arg
_ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok
, do
return $ SingleRevisionExpression $ StaticRef tok
]
choice
[ do
SingleRevisionExpression rev <- return range
suffix <- takeWhile1P Nothing (\x -> isNumber x || x `elem` [ '~', '^', '@', '{', '}' ])
return $ SingleRevisionExpression $ ModifiedRevision suffix rev
, do
return range
]
|