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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 Data.Maybe (mapMaybe)
import Types
-- | 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 [Lint] (Either Lint) a
-- this is wrapped in a newtype because Aeson is silly and wants
-- to serialise Either as { "Right" : … } or { "Left" : … } ...
type LintResult' a = Either Lint (a, [Lint])
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
lintToDep :: Lint -> Maybe Dep
lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
lintsToDeps :: LintResult a -> [Dep]
lintsToDeps (LintResult a) = case a of
Left (Depends dep) -> [dep]
Left _ -> []
Right (_, lints) -> mapMaybe lintToDep lints
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter ()
lint level = tell . (: []) . hint level
dependsOn :: Dep -> LintWriter ()
dependsOn dep = tell . (: []) $ Depends dep
warn = lint Warning
info = lint Info
forbid = lint Forbidden
suggest = lint Suggestion
complain = lint Error
dependsLocal = dependsOn . Local
dependsLink = dependsOn . Link
dependsMapService = dependsOn . MapLink
-- 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 Lint 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
|
