summaryrefslogtreecommitdiff
path: root/lib/CheckMap.hs
blob: 93c8696d54c7fc741ef3147f3c5a77684d9a80ed (plain)
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
{-# 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.Map         (Map, fromList, 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           Data.Aeson.Types ((.=))
import           Data.Map.Lazy    (foldlWithKey)
import           LintWriter       (LintResult (..), LintWriter, askContext,
                                   filterLintLevel, invertLintResult, lintToDep,
                                   resultToDeps, resultToLints, resultToOffers,
                                   runLintWriter)
import           Properties       (checkLayerProperty, checkMap, checkTileset)
import           Tiled2           (HasName (getName),
                                   HasProperties (getProperties),
                                   Layer (layerName, layerProperties),
                                   LoadResult (..),
                                   Tiledmap (tiledmapLayers, tiledmapTilesets),
                                   Tileset (tilesetName), 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] --Map Text (LintResult Layer)
  , mapresultTileset  :: Map Text (LintResult Tileset)
  , mapresultGeneral  :: [Lint]
  , mapresultDepends  :: [Dep]
  , mapresultProvides :: [Text]
  } deriving (Generic)

instance ToJSON MapResult where
  toJSON res = A.object
    [ "layer" .= CollectedLints (fmap getName <$> mapresultLayer res) --mapresultLayer res
    , "tileset" .= 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
      { mapresultLayer = mempty
      , mapresultTileset = mempty
      , mapresultDepends = []
      , mapresultProvides = []
      , mapresultGeneral =
        [ 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 = layer'
  , mapresultTileset = fromList tileset
  , mapresultGeneral = generalLints
  , mapresultDepends = --concatMap (resultToDeps . snd) layer
    {-<>-} mapMaybe lintToDep generalLints
    <> concatMap (resultToDeps . snd) tileset
  , mapresultProvides = mempty --concatMap (resultToOffers . snd) layer
  }
  where
    layer' =  M.unionsWith (<>) $ fmap invertLintResult layer

    layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
      where runCheck l = runLintWriter l depth checkLayer
    tileset =  V.toList . V.map runCheck $ tiledmapTilesets tiledmap
      where runCheck l = (tilesetName l, runLintWriter l depth (checkTileset l))

    -- 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 prettyLints == ""
    then "  all good!\n" else prettyLints
    where
      prettyLints = T.concat $ prettyGeneral <> prettyLayer
        <> prettyTileset
      -- TODO: this can be simplified further
      prettyLayer :: [Text]
      prettyLayer = mapMaybe
        (\(_,l) -> Just $ {-prettyprint level <> -}(T.concat $ fmap prettyprint $ fmap getName l))
        (toList . mapresultLayer $ mapResult)
      prettyTileset :: [Text]
      prettyTileset = mapMaybe
        (\(_,t) -> Just $ prettyprint (level, t))
        (toList . mapresultTileset $ mapResult)
      prettyGeneral :: [Text]
      prettyGeneral = map
        ((<> "\n") . prettyprint)
        . filterLintLevel level
        $ mapresultGeneral mapResult