summaryrefslogtreecommitdiff
path: root/lib/CheckMap.hs
blob: aa4616a950e8c543877af02fe523d28424c09075 (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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Module that contains the high-level checking functions
module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where

import           Universum

import           Data.Aeson       (ToJSON (toJSON))
import qualified Data.Aeson       as A
import           Data.Aeson.Types ((.=))
import qualified Data.Map         as M
import qualified Data.Text        as T
import qualified Data.Vector      as V


import           Badges           (Badge)
import           Data.Tiled       (Layer (layerLayers, layerName),
                                   Tiledmap (tiledmapLayers, tiledmapTilesets),
                                   loadTiledmap)
import           LintConfig       (LintConfig (..), LintConfig')
import           LintWriter       (LintResult, invertLintResult,
                                   resultToAdjusted, resultToBadges,
                                   resultToDeps, resultToLints, resultToOffers,
                                   runLintWriter, resultToCWs)
import           Properties       (checkLayer, checkMap, checkTileset)
import           System.FilePath  (takeFileName)
import           Types            (Dep (MapLink),
                                   Hint (Hint, hintLevel, hintMsg), Level (..),
                                   lintsToHints)
import           Util             (PrettyPrint (prettyprint), prettyprint)


data ResultKind = Full | Shrunk

type family Optional (a :: ResultKind) (b :: *) where
  Optional Full b = b
  Optional Shrunk b = ()

-- | What this linter produces: lints for a single map
data MapResult (kind :: ResultKind) = MapResult
  { mapresultLayer    :: Map Hint [Text]
  -- ^ lints that occurred in one or more layers
  , mapresultTileset  :: Map Hint [Text]
  -- ^ lints that occurred in one or more tilesets
  , mapresultDepends  :: [Dep]
  -- ^ (external and local) dependencies of this map
  , mapresultProvides :: [Text]
  -- ^ entrypoints provided by this map (needed for dependency checking)
  , mapresultAdjusted :: Optional kind (Maybe Tiledmap)
  -- ^ the loaded map, with adjustments by the linter
  , mapresultBadges   :: [Badge]
  -- ^ badges that can be found on this map
  , mapresultCWs      :: [Text]
  -- ^ collected CWs that apply to this map
  , mapresultGeneral  :: [Hint]
  -- ^ general-purpose lints that didn't fit anywhere else
  } deriving (Generic)

instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a)


instance Eq (MapResult a) where
  a == b =
    mapresultLayer a == mapresultLayer b &&
    mapresultTileset a == mapresultTileset b &&
    -- mapresultBadges a == mapresultBadges b &&
    mapresultGeneral a == mapresultGeneral b


instance ToJSON (MapResult a) where
  toJSON res = A.object
    [ "layer" .= CollectedLints (mapresultLayer res)
    , "tileset" .= CollectedLints (mapresultTileset res)
    , "general" .= mapresultGeneral 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" .= truncated cs ]) col
    where truncated cs = if length cs > 10
            then take 9 cs <> [ "..." ]
            else cs


shrinkMapResult :: MapResult Full -> MapResult Shrunk
shrinkMapResult !res = res { mapresultAdjusted = () }

-- | 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 :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full))
loadAndLintMap config path depth = loadTiledmap path <&> \case
    Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty
        [ Hint Fatal . toText $
          path <> ": Fatal: " <> err
        ])
    Right waMap ->
      Just (runLinter (takeFileName path == "main.json") config waMap depth)

-- | lint a loaded map
runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full
runLinter isMain config@LintConfig{..} tiledmap depth = MapResult
  { mapresultLayer = invertThing layer
  , mapresultTileset = invertThing tileset
  , mapresultGeneral =
    [Hint Warning "main.json should link back to the lobby"
       | isMain && not (any linksLobby layerDeps)]
    <> lintsToHints (resultToLints generalResult)
  , mapresultDepends = resultToDeps generalResult
    <> layerDeps
    <> concatMap resultToDeps tileset
  , mapresultProvides = concatMap resultToOffers layer
  , mapresultAdjusted = Just adjustedMap
  , mapresultCWs = resultToCWs generalResult
  , mapresultBadges = concatMap resultToBadges layer
    <> resultToBadges generalResult
  }
  where
    linksLobby = \case
      MapLink link ->
        ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link
        || configAssemblyTag == "lobby"
      _  -> False
    layerDeps = concatMap resultToDeps layer
    layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap)
    tileset = checkThing tiledmapTilesets checkTileset
    generalResult = runLintWriter config tiledmap depth checkMap

    checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap
      where runCheck thing = runLintWriter config thing depth checker

    -- | "inverts" a LintResult, i.e. groups it by lints instead of
    --    layers / maps
    invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing

    adjustedMap = (resultToAdjusted generalResult)
      { tiledmapLayers = V.fromList
          . fmap resultToAdjusted
          $ take (length (tiledmapLayers tiledmap)) layer
      , tiledmapTilesets = V.fromList
          . fmap resultToAdjusted
          $ tileset
      }

-- | Recursively checks a layer.
--
-- This is apparently necessary because someone thought it would be a good
-- idea to have group layers, even if their entire semantics appear to be
-- "they're group layers"; they don't seem to /do/ anything …
--
-- Note that this will flatten the layer structure and give them all back
-- in a single list, but the ones that were passed in will always be at
-- the head of the list.
checkLayerRec :: LintConfig' -> Int -> [Layer] -> [LintResult Layer]
checkLayerRec config depth layers =
  -- reordering to get the correct ones back up front
  (\rs -> fmap fst rs <> concatMap snd rs)
  -- map over all input layers
  $ flip fmap layers $ \parent ->
  case layerLayers parent of
    -- not a group layer; just lint this one
    Nothing ->
      (runLintWriter config parent depth checkLayer,[])
    -- this is a group layer. Fun!
    Just sublayers ->
      (parentResult, subresults)
      where
        -- Lintresults for sublayers with adjusted names
        subresults :: [LintResult Layer]
        subresults =
          take (length sublayers)
          . fmap (fmap (\l -> l { layerName = layerName parent <> "/" <> layerName l } ))
          $ subresults'

        -- Lintresults for sublayers and subsublayers etc.
        subresults' =
          checkLayerRec config depth sublayers

        -- lintresult for the parent layer
        parentResult = runLintWriter config parentAdjusted depth checkLayer

        -- the parent layer with adjusted sublayers
        parentAdjusted =
          parent { layerLayers = Just (fmap resultToAdjusted subresults') }



-- human-readable lint output, e.g. for consoles
instance PrettyPrint (Level, MapResult a) where
  prettyprint (_, 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 :: (MapResult a -> Map Hint [Text]) -> [Text]
      prettyLints getter = fmap
        (\(h, cs) -> prettyprint h
          <> "\n    (in "
          <> 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, "") cs)
          <> ")\n")
        (M.toList . getter $ mapResult)

      prettyGeneral :: [Text]
      prettyGeneral = map
        ((<> "\n") . prettyprint)
        $ mapresultGeneral mapResult