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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains the high-level checking functions
module CheckMap (loadAndLintMap) where
import Control.Monad.Trans.Writer (WriterT (runWriterT))
import Data.Aeson (ToJSON)
import Data.Map (Map, fromList, toList)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics (Generic)
import LintWriter (Hint (..), Level (..),
LintResult (..), LintWriter, hint)
import Properties (checkProperty)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers),
loadTiledmap)
import Util (showText)
-- | What this linter produces: lints for a single map
data MapResult a = MapResult
{ mapresultLayer :: Maybe (Map Text (LintResult a))
, mapresultGeneral :: [Hint]
} deriving (Generic, ToJSON)
-- | this module's raison d'être
loadAndLintMap :: FilePath -> IO (MapResult ())
loadAndLintMap path = loadTiledmap path >>= pure . \case
Left err -> MapResult
{ mapresultLayer = Nothing
, mapresultGeneral =
[ hint Fatal . T.pack $
path <> ": parse error (probably invalid json/not a tiled map): " <> err
]
}
Right waMap ->
runLinter waMap
-- | lint a loaded map
runLinter :: Tiledmap -> MapResult ()
runLinter tiledmap = MapResult
{ mapresultLayer = Just layer
, mapresultGeneral = [] -- no general lints for now
}
where
layer :: Map Text (LintResult ())
layer = fromList . V.toList . V.map runCheck $ tiledmapLayers tiledmap
where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
-- | collect lints on a single map layer
checkLayer :: Layer -> LintWriter ()
checkLayer layer =
mapM_ (checkProperty layer) (layerProperties layer)
-- this instance of show produces a reasonably human-readable
-- list of lints that can be shown e.g. on a console
instance Show a => Show (MapResult a) where
show mapResult = concat $ prettyGeneral <> prettyLayer
where
-- TODO: this can be simplified further
prettyLayer :: [String]
prettyLayer = mapMaybe
(\(name, lints) -> T.unpack <$> showResult name lints)
(maybe [] toList . mapresultLayer $ mapResult)
prettyGeneral :: [String]
prettyGeneral = show <$> mapresultGeneral mapResult
-- TODO: possibly expand this to something more detailed?
showContext :: Text -> Text
showContext ctxt = " (in layer " <> ctxt <> ")\n"
-- | pretty-printer for a LintResult. Isn't an instance of Show since
-- it needs to know about the result's context (yes, there could be
-- a wrapper type for that – but I wasn't really in the mood)
showResult :: Show a => Text -> LintResult a -> Maybe Text
showResult ctxt (LintResult (Left hint)) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
showResult _ (LintResult (Right (_, []))) = Nothing
showResult ctxt (LintResult (Right (_, hints))) = Just $ T.concat (mapMaybe showHint hints)
where
-- TODO: make the "log level" configurable
showHint Hint { hintMsg, hintLevel } = case hintLevel of
Info -> Nothing
_ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
ctxtHint = showContext ctxt
|
