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
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Issue (Issue (..), Provenance (..), fromMatch, id) where
import Data.Binary (Binary, Put, get, put)
import Data.ByteString.Lazy (toStrict)
import Data.Fixed (Pico)
import Data.Function ((&))
import Data.List (find, foldl')
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Calendar (Day (..), toModifiedJulianDay)
import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime)
import GHC.Generics (Generic)
import Issue.Tag (Tag (..))
import Issue.Tag qualified as I
import Issue.Text qualified as I
import Process (sh)
import System.Process.Typed (setWorkingDir)
import TreeGrepper.Match (Match (..))
import TreeGrepper.Match qualified as G
import TreeGrepper.Result (Result (..))
import TreeGrepper.Result qualified as G
import Prelude hiding (id)
data Issue = Issue
{ title :: Text,
description :: Maybe Text,
file :: String,
provenance :: Maybe Provenance,
start :: G.Position,
end :: G.Position,
tags :: [Tag],
internalTags :: [Tag]
}
deriving (Show, Binary, Generic)
data Provenance = Provenance
{ firstCommit :: Text,
date :: UTCTime,
authorEmail :: Text,
authorName :: Text
}
deriving (Show, Generic, Binary)
-- XXX These are taken from `Data.Binary.Orphans` [1]. I cannot get importing
-- the instance from the package to work.. so we use `-fno-warn-orphans` here.
--
-- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132
instance Binary UTCTime where
get = UTCTime <$> get <*> get
put (UTCTime d dt) = put d >> put dt
instance Binary Day where
get = fmap ModifiedJulianDay get
put = put . toModifiedJulianDay
instance Binary DiffTime where
get = fmap picosecondsToDiffTime get
put = (put :: Pico -> Put) . realToFrac
id :: Issue -> Maybe String
id issue =
(\(Tag _ v) -> T.unpack v)
<$> ( find (\(Tag k _) -> k == "id") $
issue.tags ++ issue.internalTags
)
fromMatch :: FilePath -> G.Result -> G.Match -> IO (Maybe Issue)
fromMatch cwd result match = do
rawProvenance <-
fmap (T.splitOn "\NUL" . head . T.lines . decodeUtf8 . toStrict) $
sh $
"git show --quiet --format='%H%x00%ai%x00%ae%x00%an'"
& setWorkingDir cwd
let provenance =
case rawProvenance of
firstCommit' : rawDate : authorEmail : authorName : _ ->
let date = read (T.unpack rawDate)
in Just
Provenance
{ firstCommit = firstCommit',
date = date,
authorEmail = authorEmail,
authorName = authorName
}
_ ->
Nothing
pure
( if any (\marker -> T.isPrefixOf marker title') issueMarkers
then
Just
Issue
{ title = title,
description = description,
file = result.file,
provenance = provenance,
start = match.start,
end = match.end,
tags = maybe [] I.extractTags description,
internalTags = I.internalTags title
}
else Nothing
)
where
(title', description) = I.extractText result.file_type match.text
title = stripIssueMarkers title'
issueMarkers :: [Text]
issueMarkers =
[ "TODO",
"FIXME",
"QUESTION"
]
stripIssueMarkers :: Text -> Text
stripIssueMarkers text =
foldl' (stripIssueMarker) text issueMarkers
stripIssueMarker :: Text -> Text -> Text
stripIssueMarker text marker =
maybe text T.stripStart (T.stripPrefix marker text)
|
