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
129
130
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | basic types for the linter to eat and produce
-- The dark magic making thse useful is in LintWriter
module Types
( Level(..)
, Lint(..)
, Dep(..)
, Hint(..)
, hint
, lintLevel
, lintsToHints
) where
import Universum
import Control.Monad.Trans.Maybe ()
import Data.Aeson (FromJSON, ToJSON (toJSON),
ToJSONKey, (.=))
import Badges (Badge)
import qualified Data.Aeson as A
import Paths (RelPath)
import Util (PrettyPrint (..))
import WithCli (Argument, atomicArgumentsParser)
import WithCli.Pure (Argument (argumentType, parseArgument),
HasArguments (argumentsParser))
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData)
instance Argument Level where
argumentType Proxy = "Lint Level"
parseArgument arg = case arg of
"info" -> Just Info
"suggestion" -> Just Suggestion
"warning" -> Just Warning
"forbidden" -> Just Forbidden
"error" -> Just Error
"fatal" -> Just Fatal
_ -> Nothing
instance HasArguments Level where
argumentsParser = atomicArgumentsParser
-- | a hint comes with an explanation (and a level), or is a dependency
-- (in which case it'll be otherwise treated as an info hint)
data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] | Jitsi Text
deriving (Ord, Eq, Generic)
data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
deriving (Generic, Ord, Eq, NFData)
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
} deriving (Generic, Ord, Eq, NFData)
-- | shorter constructor (called hint because (a) older name and
-- (b) lint also exists and is monadic)
hint :: Level -> Text -> Lint
hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
-- | dependencies just have level Info
lintLevel :: Lint -> Level
lintLevel (Lint h) = hintLevel h
lintLevel _ = Info
lintsToHints :: [Lint] -> [Hint]
lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing})
-- instance PrettyPrint Lint where
-- prettyprint (Lint Hint { hintMsg, hintLevel } ) =
-- " " <> show hintLevel <> ": " <> hintMsg
-- prettyprint (Depends dep) =
-- " Info: found dependency: " <> prettyprint dep
-- prettyprint (Offers dep) =
-- " Info: map offers entrypoint " <> prettyprint dep
-- prettyprint (Badge _) =
-- " Info: found a badge."
-- prettyprint (CW cws) =
-- " CWs: " <> show cws
instance PrettyPrint Hint where
prettyprint (Hint level msg) = " " <> show level <> ": " <> msg
-- instance ToJSON Lint where
-- toJSON (Lint h) = toJSON h
-- toJSON (Depends dep) = A.object
-- [ "msg" .= prettyprint dep
-- , "level" .= A.String "Dependency Info" ]
-- toJSON (Offers l) = A.object
-- [ "msg" .= prettyprint l
-- , "level" .= A.String "Entrypoint Info" ]
-- toJSON (Badge _) = A.object
-- [ "msg" .= A.String "found a badge"
-- , "level" .= A.String "Badge Info"]
-- toJSON (CW cws) = A.object
-- [ "msg" .= A.String "Content Warning"
-- , "level" .= A.String "CW Info" ]
instance ToJSON Hint where
toJSON (Hint l m) = A.object
[ "msg" .= m, "level" .= l ]
instance ToJSON Dep where
toJSON = \case
Local text -> json "local" $ prettyprint text
Link text -> json "link" text
MapLink text -> json "mapservice" text
LocalMap text -> json "map" $ prettyprint text
where
json :: A.Value -> Text -> A.Value
json kind text = A.object [ "kind" .= kind, "dep" .= text ]
instance PrettyPrint Dep where
prettyprint = \case
Local dep -> "[local dep: " <> prettyprint dep <> "]"
Link dep -> "[link dep: " <> dep <> "]"
MapLink dep -> "[map service dep: " <> dep <> "]"
LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]"
|
