diff options
Diffstat (limited to 'walint/CheckMap.hs')
| -rw-r--r-- | walint/CheckMap.hs | 227 |
1 files changed, 227 insertions, 0 deletions
diff --git a/walint/CheckMap.hs b/walint/CheckMap.hs new file mode 100644 index 0000000..ef80a7f --- /dev/null +++ b/walint/CheckMap.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# 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, + resultToCWs, resultToDeps, resultToJitsis, + resultToLints, resultToOffers, runLintWriter) +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 :: Type) 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 + , mapresultJitsis :: [Text] + -- ^ all jitsi room slugs mentioned in 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 mempty + [ Hint Fatal . toText $ "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 + , mapresultJitsis = concatMap resultToJitsis tileset + <> concatMap resultToJitsis layer + , 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 |