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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains the high-level checking functions
module CheckMap (loadAndLintMap, MapResult(..)) where
import Data.Aeson (ToJSON (toJSON))
import qualified Data.Aeson as A
import Data.Aeson.Types ((.=))
import Data.Map (Map, toList)
import qualified Data.Map as M
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 (LintWriter, askContext, filterLintLevel,
invertLintResult, lintToDep, resultToDeps,
resultToLints, resultToOffers, runLintWriter)
import Properties (checkLayerProperty, checkMap, checkTileset)
import Tiled2 (HasName (getName),
HasProperties (getProperties), Layer,
LoadResult (..),
Tiledmap (tiledmapLayers, tiledmapTilesets),
Tileset, loadTiledmap)
import Types (Dep, Hint (hintLevel, hintMsg), Level (..),
Lint (..), hint)
import Util (PrettyPrint (prettyprint), prettyprint)
-- | What this linter produces: lints for a single map
data MapResult = MapResult
{ mapresultLayer :: Map Hint [Layer]
, mapresultTileset :: Map Hint [Tileset] --Map Text (LintResult Tileset)
, mapresultDepends :: [Dep]
, mapresultProvides :: [Text]
, mapresultGeneral :: [Lint]
} deriving (Generic)
instance ToJSON MapResult where
toJSON res = A.object
[ "layer" .= CollectedLints (fmap getName <$> mapresultLayer res)
, "tileset" .= CollectedLints (fmap getName <$> mapresultTileset res)
, "general" .= mapresultGeneral res
-- TODO: not sure if these are necessary of even useful
--, "depends" .= mapresultDepends res
--, "provides" .= mapresultProvides res
]
newtype CollectedLints = CollectedLints (Map Hint [Text])
instance ToJSON CollectedLints where
toJSON (CollectedLints col) = toJSON
. M.mapKeys hintMsg
$ M.mapWithKey (\h cs -> A.object [ "level" .= hintLevel h, "in" .= cs ]) col
-- | this module's raison d'être
-- Lints the map at `path`, and limits local links to at most `depth`
-- layers upwards in the file hierarchy
loadAndLintMap :: FilePath -> Int -> IO (Maybe MapResult)
loadAndLintMap path depth = loadTiledmap path >>= pure . \case
DecodeErr err -> Just $ MapResult mempty mempty mempty mempty
[ hint Fatal . T.pack $
path <> ": Fatal: " <> err
]
IOErr _ -> Nothing
Loaded waMap ->
Just (runLinter waMap depth)
-- | lint a loaded map
runLinter :: Tiledmap -> Int -> MapResult
runLinter tiledmap depth = MapResult
{ mapresultLayer = invertThing layer
, mapresultTileset = invertThing tileset
, mapresultGeneral = generalLints
, mapresultDepends = mapMaybe lintToDep generalLints
<> concatMap resultToDeps layer
<> concatMap resultToDeps tileset
, mapresultProvides = concatMap resultToOffers layer
}
where
layer = checkThing tiledmapLayers checkLayer
tileset = checkThing tiledmapTilesets checkTileset
checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap
where runCheck thing = runLintWriter thing depth checker
-- | "inverts" a LintResult, i.e. groups it by lints instead of
-- layers / maps
invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing
-- lints collected from properties
generalLints =
resultToLints $ runLintWriter tiledmap depth checkMap
-- | collect lints on a single map layer
checkLayer :: LintWriter Layer
checkLayer = do
layer <- askContext
mapM_ checkLayerProperty (getProperties layer)
-- human-readable lint output, e.g. for consoles
instance PrettyPrint (Level, MapResult) where
prettyprint (level, mapResult) = if complete == ""
then " all good!\n" else complete
where
complete = T.concat $ prettyGeneral
<> prettyLints mapresultLayer
<> prettyLints mapresultTileset
-- | pretty-prints a collection of Hints, printing each
-- Hint only once, then a list of its occurences line-wrapped
-- to fit onto a decent-sized terminal
prettyLints :: HasName a => (MapResult -> Map Hint [a]) -> [Text]
prettyLints getter = fmap
(\(h, cs) -> prettyprint h
<> "\n (in "
-- foldl :: ((length of current line, acc) -> next ctxt -> list) -> ...
<> snd (foldl (\(l,a) c -> case l of
0 -> (T.length c, c)
_ | l < 70 -> (l+2+T.length c, a <> ", " <> c)
_ -> (6+T.length c, a <> ",\n " <> c)
)
(0, "") (fmap getName cs))
<> ")\n")
(toList . getter $ mapResult)
prettyGeneral :: [Text]
prettyGeneral = map
((<> "\n") . prettyprint)
. filterLintLevel level
$ mapresultGeneral mapResult
|
