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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
module History
( History (..),
getHistory,
)
where
import CMark qualified as D
import Cache (cachedMaybe)
import Control.Exception (catch, handle, try)
import Data.Binary (Binary)
import Data.ByteString.Lazy qualified as LB
import Data.Function (on, (&))
import Data.List (deleteFirstsBy, find)
import Data.List.NonEmpty qualified as N
import Data.Maybe (catMaybes, isJust)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
import Die (die)
import Exception qualified as E
import GHC.Generics (Generic)
import Git qualified
import Git.CommitHash (CommitHash (..))
import Git.CommitHash qualified as C
import Issue qualified as I
import Issue.Parser qualified as I
import Issue.Tag qualified as I
import Issue.Text qualified as I
import IssueEvent (IssueEvent (..))
import Patch qualified as A
import Process (proc, sh)
import Render qualified as P
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Typed (setWorkingDir)
import TreeGrepper.Comment qualified as G
import Tuple ()
-- TODO Reduce cached data size
--
-- Right now we are caching complete `Issue` instances, which
-- contain the full issue title and description. For a fast
-- lookup it may already be enough to only store the issue's
--
-- \* filename
-- \* start position
-- \* end position
--
-- With this information we can use git to quickly look up the
-- complete issue text and parse it.
--
-- @topic caching
-- @backlog
data History = History
{ commitHash :: CommitHash,
issues :: [I.Issue],
issueEvents :: [IssueEvent]
}
deriving (Show, Generic, Binary)
getHistory :: IO History
getHistory = getHistoryOf WorkingTree
getHistoryOf :: CommitHash -> IO History
getHistoryOf commitHash = cachedMaybe (C.toText commitHash) do
maybeParentCommitHash <- getParentCommitHashOf commitHash
case maybeParentCommitHash of
Just parentCommitHash -> do
parentHistory <- getHistoryOf parentCommitHash
scramble <- getScrambleOf commitHash
propagate commitHash parentHistory scramble
Nothing -> unsafeAssume commitHash =<< getScrambleOf commitHash
getParentCommitHashOf :: CommitHash -> IO (Maybe CommitHash)
getParentCommitHashOf commitHash =
either
(\_ -> Nothing)
(Just . Commit . T.strip . T.decodeUtf8 . LB.toStrict)
<$> try @E.ProcessException
( case commitHash of
WorkingTree -> sh "git show -s --format=%H HEAD"
Commit hash -> sh (proc "git show -s --format=%%H %^" hash)
)
-- | `Scramble` records the complete issues ONLY in files that have
-- been changed in the commit.
data Scramble = Scramble
{ commitHash :: CommitHash,
filesChanged :: [FilePath],
issues :: [I.Issue]
}
deriving (Show, Binary, Generic)
getScrambleOf :: CommitHash -> IO Scramble
getScrambleOf commitHash = do
(issues, filesChanged) <- getIssuesAndFilesChanged commitHash
pure $ Scramble {..}
getIssuesAndFilesChanged :: CommitHash -> IO ([I.Issue], [FilePath])
getIssuesAndFilesChanged commitHash = do
files <- Git.getChangedFilesOf commitHash
issues <-
concat
<$> catch
(mapM (getIssues commitHash) files)
(\(e :: E.InvalidTreeGrepperResult) -> die (show e))
pure (issues, files)
-- | Get all issues in the given directory and file.
getIssues :: CommitHash -> FilePath -> IO [I.Issue]
getIssues commitHash filename =
handle (\(_ :: E.UnknownFileExtension) -> pure []) $
fmap catMaybes . mapM (fromComment commitHash)
=<< G.getComments commitHash filename
-- | Note that `provenance` is trivial and needs to be fixed up later.
fromComment :: CommitHash -> G.Comment -> IO (Maybe I.Issue)
fromComment commitHash comment = do
commit <- Git.getCommitOf commitHash
let provenance = I.Provenance commit commit
pure $
( \parseResult ->
let (markers, title) =
I.stripIssueMarkers (T.pack (show (P.render parseResult.heading)))
in I.Issue
{ title = title,
description = N.nonEmpty parseResult.paragraphs,
file = comment.file,
provenance = provenance,
start = comment.start,
end = comment.end,
tags = I.extractTags parseResult.tags,
markers = markers,
rawText = rawText,
commentStyle = commentStyle,
comments = N.nonEmpty parseResult.comments,
closed = False
}
)
<$> I.parse I.issueMarkers (D.commonmarkToNode [] rawText)
where
(commentStyle, rawText) = G.uncomment comment.file_type comment.text
propagate :: CommitHash -> History -> Scramble -> IO History
propagate commitHash oldHistory scramble = do
let issues = propagateIssues oldHistory.issues scramble
issueEvents <- propagateIssueEvents oldHistory.issueEvents oldHistory.issues commitHash issues
pure $ History {..}
propagateIssues :: [I.Issue] -> Scramble -> [I.Issue]
propagateIssues oldIssues partialCommitInfo =
mergeListsBy
eq
( \old new ->
new
{ I.provenance =
I.Provenance
{ first = old.provenance.first,
last =
if ((/=) `on` (.rawText)) old new
then new.provenance.last
else old.provenance.last
},
I.closed = False
}
)
( \old ->
if elemBy eq old partialCommitInfo.issues
|| not (old.file `elem` partialCommitInfo.filesChanged)
then old
else old {I.closed = True}
)
id
oldIssues
partialCommitInfo.issues
propagateIssueEvents :: [IssueEvent] -> [I.Issue] -> CommitHash -> [I.Issue] -> IO [IssueEvent]
propagateIssueEvents oldIssueEvents oldIssues commitHash issues =
fmap (oldIssueEvents ++) $ newIssueEvents oldIssues commitHash issues
newIssueEvents :: [I.Issue] -> CommitHash -> [I.Issue] -> IO [IssueEvent]
newIssueEvents oldIssues' commitHash issues' =
sequence $
concat
[ [IssueCreated commitHash issue <$> patchCreated issue | issue <- deleteFirstsBy eq issues oldIssues],
[ IssueChanged commitHash oldIssue newIssue <$> patchChanged oldIssue newIssue
| (newIssue : oldIssue : _) <- intersectBy' eq issues oldIssues,
neq newIssue oldIssue
],
[IssueDeleted commitHash issue <$> patchDeleted issue | issue <- deleteFirstsBy eq oldIssues issues]
]
where
issues = filter (not . (.closed)) issues'
oldIssues = filter (not . (.closed)) oldIssues'
patchCreated new = diff "" new.rawText
patchChanged old new = diff old.rawText new.rawText
patchDeleted old = diff old.rawText ""
diff old new = withSystemTempDirectory "diff" $ \tmp -> do
let cwd = tmp
T.writeFile (tmp </> "old") old
T.writeFile (tmp </> "new") new
A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd)
unsafeAssume :: CommitHash -> Scramble -> IO History
unsafeAssume commitHash scramble = do
let issues = scramble.issues
issueEvents <- propagateIssueEvents [] [] commitHash issues
pure $ History {..}
eq :: I.Issue -> I.Issue -> Bool
eq = (==) `on` (.id)
neq :: I.Issue -> I.Issue -> Bool
neq = (/=) `on` (.rawText)
mergeListsBy :: (a -> a -> Bool) -> (a -> a -> b) -> (a -> b) -> (a -> b) -> [a] -> [a] -> [b]
mergeListsBy eq onBoth onLeft onRight lefts rights =
concat
[ [ maybe (onLeft left) (onBoth left) right
| left <- lefts,
right <-
let rights' = filter (eq left) rights
in if null rights' then [Nothing] else (map Just rights')
],
[ onRight right
| right <- rights,
not (elemBy eq right lefts)
]
]
-- | A variant of `Data.List.intersectBy` that retuns the witnesses of the
-- intersection.
intersectBy' :: (a -> a -> Bool) -> [a] -> [a] -> [[a]]
intersectBy' eq xs ys = filter (not . null) (map (\x -> x : filter (eq x) ys) xs)
-- | A variant of `elem` that uses a custom comparison function.
elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq x xs = isJust $ find (eq x) xs
|
