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
|
{-# 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 (LintResult (..), LintWriter,
lintsToDeps, resultToLints,
runLintWriter)
import Properties (checkLayerProperty,
checkMapProperty)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers, tiledmapProperties),
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 a))
, 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 = propertyLints -- no general lints for now
, mapresultDepends = concatMap (lintsToDeps . snd) layer
}
where
layerMap :: Map Text (LintResult ())
layerMap = fromList layer
layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
-- lints collected from properties
propertyLints = runLintWriter
$ mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
-- | collect lints on a single map layer
checkLayer :: Layer -> LintWriter ()
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 a -> Maybe Text
showResult ctxt (LintResult res) = case res of
Left hint -> Just $ "Fatal: " <> prettyprint hint
Right (_, []) -> Nothing
Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints)
where
-- TODO: make the "log level" configurable
showHint hint = case lintLevel hint of
Info -> Nothing
_ -> Just $ prettyprint hint <> ctxtHint
ctxtHint = showContext ctxt
|
