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
|
module Issue
( Issue (..),
Provenance (..),
fromMatch,
id,
getIssuesPar,
)
where
import Control.Exception (handle, throw)
import Data.Aeson (eitherDecode)
import Data.Binary (Binary)
import Data.Function ((&))
import Data.List (find, foldl')
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Text qualified as T
import Exception qualified as E
import GHC.Generics (Generic)
import Issue.Provenance (Provenance (..), commitFromHEAD)
import Issue.Tag (Tag (..))
import Issue.Tag qualified as I
import Issue.Text qualified as I
import Parallel (parMapM)
import Process (proc, sh)
import System.FilePath (takeExtension)
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,
-- TODO Make provenance obligatory
--
-- I cannot think of instances where an issue exists without a provenance..
provenance :: Maybe Provenance,
start :: G.Position,
end :: G.Position,
tags :: [Tag],
internalTags :: [Tag]
}
deriving (Show, Binary, Generic, Eq)
id :: Issue -> Maybe String
id issue =
(\(Tag _ v) -> T.unpack <$> v)
=<< find (\(Tag k _) -> k == "id") (issue.tags ++ issue.internalTags)
-- TODO Refactor non-issues
--
-- This does not return an issue, as provenance is not computed over its
-- history. Maybe this should return a different type, or be internal to
-- `History`? Also, `internalTags` suffer.
fromMatch :: FilePath -> G.Result -> G.Match -> IO (Maybe Issue)
fromMatch cwd result match = do
commit <- commitFromHEAD cwd
let provenance = Provenance commit commit
pure
( if any (\marker -> T.isPrefixOf marker title') issueMarkers
then
Just
Issue
{ title = title,
description = description,
file = result.file,
provenance = Just provenance,
start = match.start,
end = match.end,
tags = maybe [] I.extractTags description,
internalTags = I.internalTags title (Just provenance)
}
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)
-- | Get all issues in the given directory and files. Runs
-- parallelized.
getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]]
getIssuesPar cwd files =
parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files
-- | Get all issues in the given directory and file.
getIssues :: FilePath -> FilePath -> IO [Issue]
getIssues cwd filename = do
let extension = takeExtension filename
treeGrepperLanguage =
-- TODO Add support for all tree-grepper supported files
--
-- tree-grepper supported files can be listed through `tree-grepper
-- --languages`.
case extension of
".elm" -> "elm"
".hs" -> "haskell"
".nix" -> "nix"
".sh" -> "sh"
_ -> throw (E.UnknownFileExtension extension)
treeGrepperQuery =
case extension of
".elm" -> "([(line_comment) (block_comment)])"
".hs" -> "(comment)"
".nix" -> "(comment)"
".sh" -> "(comment)"
_ -> throw (E.UnknownFileExtension extension)
decode raw =
case eitherDecode raw of
Left e -> throw (E.InvalidTreeGrepperResult e)
Right treeGrepperResult -> treeGrepperResult
matches <-
concatMap (\result -> map ((,) result) result.matches)
. map fixTreeGrepper
. decode
<$> sh
( proc
"tree-grepper --query % % --format json %"
(treeGrepperLanguage :: String)
(treeGrepperQuery :: String)
filename
& setWorkingDir cwd
)
catMaybes <$> mapM (uncurry (fromMatch cwd)) matches
fixTreeGrepper :: G.Result -> G.Result
fixTreeGrepper treeGrepperResult =
treeGrepperResult {G.matches = G.merge treeGrepperResult.matches}
forgetGetIssuesExceptions :: E.UnknownFileExtension -> IO [a]
forgetGetIssuesExceptions _ = pure []
|
