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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains the high-level checking functions
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module CheckMap (loadAndLintMap) where
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 (LayerContext (..), LintResult (..), LintWriter,
lintToDep, resultToDeps, resultToLints,
runLintWriter)
import Properties (checkLayerProperty, checkMap)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers), loadTiledmap)
import Types (Dep, Level (..), Lint (..), hint, lintLevel)
import Util (PrettyPrint (prettyprint), prettyprint)
-- | What this linter produces: lints for a single map
data MapResult a = MapResult
{ mapresultLayer :: Maybe (Map Text (LintResult LayerContext))
, mapresultGeneral :: [Lint]
, mapresultDepends :: [Dep]
} deriving (Generic, ToJSON)
-- | this module's raison d'être
loadAndLintMap :: FilePath -> IO (MapResult ())
loadAndLintMap path = loadTiledmap path >>= pure . \case
Left err -> MapResult
{ mapresultLayer = Nothing
, mapresultDepends = []
, 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 layerMap
, mapresultGeneral = generalLints -- no general lints for now
, mapresultDepends = concatMap (resultToDeps . snd) layer
<> mapMaybe lintToDep generalLints
}
where
layerMap :: Map Text (LintResult LayerContext)
layerMap = fromList layer
layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
where runCheck l = (layerName l, runLintWriter (LayerContext ()) (checkLayer l))
-- lints collected from properties
generalLints =
resultToLints $ runLintWriter () (checkMap tiledmap)
-- | collect lints on a single map layer
checkLayer :: Layer -> LintWriter LayerContext
checkLayer layer =
mapM_ (checkLayerProperty layer) (layerProperties layer)
-- human-readable lint output, e.g. for consoles
instance PrettyPrint a => PrettyPrint (MapResult a) where
prettyprint mapResult = T.concat $ prettyGeneral <> prettyLayer
where
-- TODO: this can be simplified further
prettyLayer :: [Text]
prettyLayer = mapMaybe
(uncurry showResult)
(maybe [] toList . mapresultLayer $ mapResult)
prettyGeneral :: [Text]
prettyGeneral = flip (<>) "\n" . prettyprint <$> 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 PrettyPrint 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 :: Text -> LintResult c -> Maybe Text
showResult ctxt (LintResult (_, lints)) =
Just $ T.concat (mapMaybe showHint lints)
where
-- TODO: make the "log level" configurable
showHint hint = case lintLevel hint of
Info -> Nothing
_ -> Just $ prettyprint hint <> ctxtHint
ctxtHint = showContext ctxt
|
