{-# 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, resultToJitsis) 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 , 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 $ 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 , 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