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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- | a monad that collects warnings, outputs, etc,
{-# LANGUAGE TupleSections #-}
module LintWriter where
import Control.Monad.Trans.Maybe ()
import Control.Monad.Writer (MonadWriter (tell), WriterT,
runWriterT)
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
import Control.Monad.Trans.Reader (Reader, asks, runReader)
import Control.Monad.Writer.Lazy (lift)
import Data.Map (Map, fromListWith)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Tiled2 (HasName (getName))
import Types
import Util (PrettyPrint (..))
-- | for now, all context we have is how "deep" in the directory tree
-- we currently are
type Context = Int
-- | a monad to collect hints, with some context (usually the containing layer/etc.)
type LintWriter ctxt = LintWriter' ctxt ()
type LintWriter' ctxt res = WriterT [Lint] (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 (<>) $ fmap (, [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
-- | run a linter
runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
runLintWriter c c' linter = LintResult (c, lints)
where lints = snd $ flip runReader (c',c) $ runWriterT linter
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter a
lint level = tell . (: []) . hint level
dependsOn :: Dep -> LintWriter a
dependsOn dep = tell . (: []) $ Depends dep
offersEntrypoint :: Text -> LintWriter a
offersEntrypoint = tell . (: []) . Offers
info = lint Info
suggest = lint Suggestion
warn = lint Warning
forbid = lint Forbidden
complain = lint Error
askContext :: LintWriter' a a
askContext = lift $ asks snd
askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks fst
|
