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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
-- | a monad that collects warnings, outputs, etc,
module LintWriter where
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
import Control.Monad.State (StateT, modify)
import Control.Monad.Trans.Reader (Reader, asks, runReader)
import Control.Monad.Trans.State (runStateT)
import Control.Monad.Writer.Lazy (lift)
import Data.Bifunctor (Bifunctor (second))
import Data.Map (Map, fromListWith)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Util (PrettyPrint (..))
import Tiled2 (HasName)
import Types
-- | for now, all context we have is how "deep" in the directory tree
-- we currently are
type Context = Int
newtype LinterState ctxt = LinterState { fromLinterState :: ([Lint], ctxt)}
-- | a monad to collect hints, with some context (usually the containing layer/etc.)
type LintWriter ctxt = LintWriter' ctxt ()
type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt)) res
-- wrapped to allow for manual writing of Aeson instances
type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
newtype LintResult ctxt = LintResult (LintResult' ctxt)
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
invertLintResult (LintResult (ctxt, lints)) =
fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints
-- better, less confusing serialisation of an Either Hint (a, [Hint]).
-- Note that Left hint is also serialised as a list to make the resulting
-- json schema more regular.
instance ToJSON (LintResult a) where
toJSON (LintResult res) = toJSON $ snd res
instance PrettyPrint ctxt => PrettyPrint (Level, LintResult ctxt) where
prettyprint (level, LintResult (ctxt, res)) =
T.concat $ map ((<> context) . prettyprint) (filterLintLevel level res)
where context = " (" <> prettyprint ctxt <> ")\n"
lintToDep :: Lint -> Maybe Dep
lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
lintToOffer :: Lint -> Maybe Text
lintToOffer = \case
Offers frag -> Just frag
_ -> Nothing
filterLintLevel :: Level -> [Lint] -> [Lint]
filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l
then Just l
else Nothing
resultToDeps :: LintResult a -> [Dep]
resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a
resultToOffers :: LintResult a -> [Text]
resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a
-- | convert a lint result into a flat list of lints
-- (throwing away information on if a single error was fatal)
resultToLints :: LintResult a -> [Lint]
resultToLints (LintResult res) = snd res
resultToAdjusted :: LintResult a -> a
resultToAdjusted (LintResult res) = fst res
-- | run a linter. Returns the adjusted context, and a list of lints
runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
runLintWriter c c' linter = LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints)
where lints = snd $ runReader ranstate (c',c)
ranstate = runStateT linter (LinterState ([], c))
tell' :: Lint -> LintWriter ctxt
tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt)
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter a
lint level text = tell' $ hint level text
dependsOn :: Dep -> LintWriter a
dependsOn dep = tell' $ Depends dep
offersEntrypoint :: Text -> LintWriter a
offersEntrypoint text = tell' $ Offers text
-- | adjusts the context. Gets a copy of the /current/ context, i.e. one which might
-- have already been changed by other lints
adjust :: (a -> a) -> LintWriter a
adjust f = modify $ LinterState . second f . fromLinterState
info = lint Info
suggest = lint Suggestion
warn = lint Warning
forbid = lint Forbidden
complain = lint Error
-- | get the context as it was originally, without any modifications
askContext :: LintWriter' a a
askContext = lift $ asks snd
askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks fst
|
