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
|
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 (..), provenanceFromHEAD)
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,
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)
fromMatch :: FilePath -> G.Result -> G.Match -> IO (Maybe Issue)
fromMatch cwd result match = do
provenance <- provenanceFromHEAD cwd
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 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 []
|
