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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
-- | a monad that collects warnings, outputs, etc,
module LintWriter
( runLintWriter
, LintWriter
, LintWriter'
, LintResult
, invertLintResult
, zoom
-- * working with lint results
, resultToDeps
, resultToOffers
, resultToBadges
, resultToLints
, resultToAdjusted
-- * Add lints to a linter
, info
, suggest
, warn
, forbid
, complain
-- * add other information to the linter
, offersEntrypoint
, offersBadge
, dependsOn
-- * get information about the linter's context
, askContext
, askFileDepth
, lintConfig
-- * adjust the linter's context
, adjust
) where
import Data.Text (Text)
import Badges (Badge)
import Control.Monad.State (MonadState (put), StateT, modify)
import Control.Monad.Trans.Reader (Reader, asks, runReader)
import Control.Monad.Trans.State (get, runStateT)
import Control.Monad.Writer.Lazy (lift)
import Data.Bifunctor (Bifunctor (second))
import Data.Map (Map, fromListWith)
import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import LintConfig (LintConfig')
import TiledAbstract (HasName (getName))
import Types (Dep, Hint, Level (..), Lint (..),
hint, lintsToHints)
-- | A monad modelling the main linter features
type LintWriter ctxt = LintWriter' ctxt ()
-- | A linter that can use pure / return things monadically
type LintWriter' ctxt res =
StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res
-- | A Linter's state: some context (which it may adjust), and a list of lints
-- | it already collected.
newtype LinterState ctxt = LinterState
{ fromLinterState :: ([Lint], ctxt)}
deriving Functor
-- | The result of running a linter: an adjusted context, and a list of lints.
-- | This is actually just a type synonym of LinterState, but kept seperately
-- | for largely historic reasons since I don't think I'll change it again
type LintResult ctxt = LinterState ctxt
-- | for now, all context we have is how "deep" in the directory tree
-- we currently are
type Context = Int
-- | run a linter. Returns the adjusted context, and a list of lints
runLintWriter
:: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
runLintWriter config context depth linter = LinterState
. fromLinterState
. snd
. runReader runstate
$ (depth, context, config)
where runstate = runStateT linter (LinterState ([], context))
zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a
zoom embed extract operation = do
config <- lintConfig id
depth <- askFileDepth
let result ctxt = runLintWriter config ctxt depth operation
LinterState (lints,a) <- get
let res = result . extract $ a
put $ LinterState
. (resultToLints res <> lints,)
. embed
. resultToAdjusted
$ res
pure $ resultToAdjusted res
-- | "invert" a linter's result, grouping lints by their messages
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text]
invertLintResult (LinterState (lints, ctxt)) =
fmap (S.toList . S.fromList . fmap getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints
resultToDeps :: LintResult a -> [Dep]
resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints
where lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
resultToOffers :: LintResult a -> [Text]
resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a
where lintToOffer = \case
Offers frag -> Just frag
_ -> Nothing
resultToBadges :: LintResult a -> [Badge]
resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a
where lintToBadge (Badge badge) = Just badge
lintToBadge _ = Nothing
-- | convert a lint result into a flat list of lints
resultToLints :: LintResult a -> [Lint]
resultToLints (LinterState res) = fst res
-- | extract the adjusted context from a lint result
resultToAdjusted :: LintResult a -> a
resultToAdjusted (LinterState res) = snd res
-- | fundamental linter operations: add a lint of some severity
info = lint Info
suggest = lint Suggestion
warn = lint Warning
forbid = lint Forbidden
complain = lint Error
-- | add a dependency to the linter
dependsOn :: Dep -> LintWriter a
dependsOn dep = tell' $ Depends dep
-- | add an offer for an entrypoint to the linter
offersEntrypoint :: Text -> LintWriter a
offersEntrypoint text = tell' $ Offers text
-- | add an offer for a badge to the linter
offersBadge :: Badge -> LintWriter a
offersBadge badge = tell' $ Badge badge
-- | get the context as it was initially, without any modifications
askContext :: LintWriter' a a
askContext = lift $ asks (\(_,a,_) -> a)
-- | ask for the file depth within the repository tree of the current map.
-- | This function brings in a lot more conceptual baggage than I'd like, but
-- | it's needed to check if relative paths lie outside the repository
askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks (\(a,_,_) -> a)
-- | ask for a specific part of the linter's global config
lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a
lintConfig get = lift $ asks (\(_,_,config) -> get config)
-- | tell, but for a singular lint. Leaves the context unchanged
tell' :: Lint -> LintWriter ctxt
tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt)
-- | small helper to tell a singlular proper lint
lint :: Level -> Text -> LintWriter a
lint level text = tell' $ hint level text
-- | adjusts the context. Gets a copy of the /current/ context,
-- | i.e. one which might have already been changed by other adjustments
adjust :: (a -> a) -> LintWriter a
adjust f = modify $ LinterState . second f . fromLinterState
|
