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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- | a monad that collects warnings, outputs, etc,
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.Maybe (mapMaybe)
import qualified Data.Text as T
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
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)
-- 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 (LintResult ctxt) where
prettyprint (LintResult (ctxt, res)) =
T.concat (map showHint res)
where showHint hint = prettyprint hint <> context
context = " (" <> prettyprint ctxt <> ")\n"
lintToDep :: Lint -> Maybe Dep
lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
resultToDeps :: LintResult a -> [Dep]
resultToDeps (LintResult a) = mapMaybe lintToDep $ 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
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
|
