diff options
Diffstat (limited to 'lib/CheckMap.hs')
| -rw-r--r-- | lib/CheckMap.hs | 234 |
1 files changed, 0 insertions, 234 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs deleted file mode 100644 index a2a0f9f..0000000 --- a/lib/CheckMap.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# 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, - 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 |