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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main where
import Data.Map (Map, (!?))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe (isJust, mapMaybe)
import qualified Data.Aeson as Aeson
import Data.Vector (Vector)
import Data.Set (Set, fromList)
import qualified Data.Vector as V
import Control.Monad.Writer
import Control.Monad.Trans.Maybe
import Tiled2
data Level = Warning | Suggestion | Info | Forbidden | Error
deriving Show
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text }
deriving Show
-- shorter constructors
suggestion msg = Hint { hintLevel = Suggestion, hintMsg = msg }
warning msg = Hint { hintLevel = Warning, hintMsg = msg }
forbidden msg = Hint { hintLevel = Forbidden, hintMsg = msg }
-- | 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 $ warning msg
-- | get an attribute from a map
getAttr :: Map Text Aeson.Value -> Text -> Either Hint Aeson.Value
getAttr props name = unwrapWarn msg $ props !? name
where msg = "field " <> name <> "does not exist"
-- | same as unwrapWarn, but for booleans
assertWarn :: Text -> Bool -> Either Hint ()
assertWarn msg cond = if cond then Right () else Left $ warning msg
-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
showText = T.pack . show
-- | same as showText, but without the "String"-prefix for strings
-- TODO: serialise back into json for printing? People may get
-- confused by the type annotations if they only know json …
showAeson :: Aeson.Value -> Text
showAeson (Aeson.String s) = showText s
showAeson v = showText v
-- | the given property should have the given value. Otherwise, warning.
propEqual :: Map Text Aeson.Value -> Text -> Aeson.Value -> Either Hint ()
propEqual props name value = do
value' <- getAttr props name
assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
<>", should be "<>showAeson value)
$ value' == value
-- |
-- This type may require some explanation.
-- Essentially, it's a monad that can short-curcuit (i.e. abort),
-- and also collect hints as it goes. Currently, both aborts and
-- hints are the same type (Hint); if the monad ends up returning
-- Left Hint, then something went entirely wrong; if it returns
-- Right (a, [Hint]), then it ran through, calculated a, and collected
-- a list of linter hints along the way.
type MaybeWriter a = WriterT [Hint] (Either Hint) a
-- | type juggling to get a single warning into MaybeWriter a
maybeWriterHint :: (Text -> Hint) -> Text -> MaybeWriter ()
maybeWriterHint constructor = tell . (: []) . constructor
warn = maybeWriterHint warning
info = maybeWriterHint (\t -> Hint { hintLevel = Info, hintMsg = t })
forbid = maybeWriterHint forbidden
suggest = maybeWriterHint suggestion
complain = maybeWriterHint (\t -> Hint { hintLevel = Error, hintMsg = t })
-- | adds quotes (but does not escape, for now!)
quote :: Text -> Text
quote text = "\"" <> text <> "\""
-- | does this layer have the given property?
hasProperty :: Text -> Layer -> Bool
hasProperty name = any
(\prop -> prop !? "name" == Just (Aeson.String name))
. layerProperties
-- | The main thing
--
-- given a property, check if it is valid. It gets a reference
-- to its own layer since sometimes the presense of one property
-- implies the presence or absense of another.
--
-- The tests in here are meant to comply with the informal spec
-- at https://workadventu.re/map-building
checkProperty :: Layer -> Map Text Aeson.Value -> MaybeWriter ()
checkProperty layer prop = do
tyObj <- lift $ getAttr prop "name"
ty <- lift $ case tyObj of
Aeson.String str -> Right str
_ -> Left (suggestion "wtf")
checkTyped ty
where checkTyped ty = case ty of
"jitsiRoom" -> do
lift $ propEqual prop "type" "string"
urlValue <- lift $ getAttr prop "value"
info $ "found jitsi room: " <> showAeson urlValue
suggestPropertyValue "jitsiTrigger" "onaction"
forbidProperty "jitsiUrl"
-- TODO: not sure if we should really disallow these entirely
forbidProperty "jitsiConfig"
forbidProperty "jitsiClientConfig"
forbidProperty "jitsiRoomAdminTag"
"jitsiTrigger" -> requireProperty "jitsiRoom"
"playAudio" -> do
-- TODO: check for url validity?
lift $ propEqual prop "type" "string"
"audioLoop" -> requireProperty "playAudio"
"audioVolume" -> requireProperty "playAudio"
"openWebsite" -> suggestPropertyValue "openWebsiteTrigger" "onaction"
"openWebsiteTrigger" -> requireProperty "openWebsite"
"openWebsitePolicy" -> requireProperty "openWebsite"
"exitUrl" -> return ()
"startLayer" -> return ()
-- could also make this a "hard error" (i.e. Left), but then it
-- stops checking other properties as checkLayer short-circuits.
_ -> warn $ "unknown property type " <> quote ty
where
-- | require some property in this layer
requireProperty name = unless (hasProperty name layer)
$ complain $ "property "<>quote name<>" requires property "<>quote ty
-- | forbid some property in this layer
forbidProperty name = when (hasProperty name layer)
$ forbid $ "property " <> quote name <> " should not be used"
-- TODO: check if the property has the correct value
suggestPropertyValue name value = unless (hasProperty name layer)
$ suggest $ "set property " <> quote name <> " to " <> quote value
checkLayer :: Layer -> MaybeWriter ()
checkLayer layer =
mapM_ (checkProperty layer) (layerProperties layer)
-- TODO: possibly expand this to something more detailed?
showContext :: Text -> Text
showContext ctxt = " (in layer " <> ctxt <> ")\n"
-- | pretty-printer for a result of WriterMaybe (currently only for errors/hints)
showResult :: Show a => Text -> Either Hint (a, [Hint]) -> Maybe Text
showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
showResult _ (Right (a, [])) = Nothing
showResult ctxt (Right (a, hints)) = Just $ showHints hints
where
showHints hints = T.concat (mapMaybe showHint hints)
-- TODO: make the "log level" configurable
showHint Hint { hintMsg, hintLevel } = case hintLevel of
Info -> Nothing
_ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
ctxtHint = showContext ctxt
main :: IO ()
main = do
Right map <- loadTiledmap "example.json"
--print $ mapJitsiUrls map
--print $ fmap layerJitsiUrls (tiledmapLayers map)
-- TODO: print the layer each hint originates from
let lines = V.mapMaybe (\layer ->
(showResult (T.pack $ layerName layer)
. runWriterT
. checkLayer)
layer)
(tiledmapLayers map)
mapM_ T.putStr lines
|
