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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | a monad that collects warnings, outputs, etc,
module LintWriter where
import Control.Monad.Trans.Maybe ()
import Control.Monad.Writer (MonadTrans (lift),
MonadWriter (tell), WriterT)
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
import GHC.Generics (Generic)
import Util (PrettyPrint(..), showText)
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
deriving (Show, Generic, ToJSON)
-- | a hint comes with an explanation (and a level)
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
} deriving (Generic, ToJSON)
instance PrettyPrint Hint where
prettyprint Hint { hintMsg, hintLevel } =
showText hintLevel <> ": " <> hintMsg
-- shorter constructor
hint :: Level -> Text -> Hint
hint level msg = Hint { hintLevel = level, hintMsg = msg }
-- | a monad to collect hints. If it yields Left, then the
-- map is flawed in some fundamental way which prevented us
-- from getting any hints at all except whatever broke it
type LintWriter a = WriterT [Hint] (Either Hint) a
-- this is wrapped in a newtype because Aeson is silly and wants
-- to serialise Either as { "Right" : … } or { "Left" : … } ...
type LintResult' a = Either Hint (a, [Hint])
newtype LintResult a = LintResult (LintResult' a)
-- 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 a => ToJSON (LintResult a) where
toJSON (LintResult r) = toJson' r
where toJson' (Left hint) = toJSON [hint]
toJson' (Right (_, hints)) = toJSON hints
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter ()
lint level = tell . (: []) . hint level
warn = lint Warning
info = lint Info
forbid = lint Forbidden
suggest = lint Suggestion
complain = lint Error
-- TODO: all these functions should probably also just operate on LintWriter
-- | converts a Maybe to an Either, with a default value for Left
unwrap :: b -> Maybe a -> Either b a
unwrap hint maybe = case maybe of
Just a -> Right a
Nothing -> Left hint
-- | unwrap and produce a warning if the value was Nothing
unwrapWarn :: Text -> Maybe a -> Either Hint a
unwrapWarn msg = unwrap $ hint Warning msg
-- | same as unwrapWarn, but for booleans
assertWarn :: Text -> Bool -> LintWriter ()
assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg
|
