CheckMap.hs

{-# 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.Aeson.Types ((.=))
import           Data.Functor     ((<&>))
import           Data.Map         (Map, toList)
import qualified Data.Map         as M
import           Data.Text        (Text)
import qualified Data.Text        as T
import qualified Data.Vector      as V
import           GHC.Generics     (Generic)


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



-- | What this linter produces: lints for a single map
data MapResult = MapResult
  { mapresultLayer    :: Map Hint [Layer]
  -- ^ lints that occurred in one or more layers
  , mapresultTileset  :: Map Hint [Tileset]
  -- ^ 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 :: Maybe Tiledmap
  -- ^ the loaded map, with adjustments by the linter
  , mapresultBadges   :: [Badge]
  -- ^ badges that can be found on this map
  , mapresultGeneral  :: [Hint]
  -- ^ general-purpose lints that didn't fit anywhere else
  } deriving (Generic)

instance ToJSON MapResult where
  toJSON res = A.object
    [ "layer" .= CollectedLints (fmap getName <$> mapresultLayer res)
    , "tileset" .= CollectedLints (fmap getName <$> 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" .= 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 :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
loadAndLintMap config path depth = loadTiledmap path <&> (\case
    DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty
        [ Hint Fatal . T.pack $
          path <> ": Fatal: " <> err
        ])
    IOErr _ -> Nothing
    Loaded waMap ->
      Just (runLinter config waMap depth))

-- | lint a loaded map
runLinter :: LintConfig' -> Tiledmap -> Int -> MapResult
runLinter config tiledmap depth = MapResult
  { mapresultLayer = invertThing layer
  , mapresultTileset = invertThing tileset
  , mapresultGeneral = lintsToHints $ resultToLints generalResult
  , mapresultDepends = resultToDeps generalResult
    <> concatMap resultToDeps layer
    <> concatMap resultToDeps tileset
  , mapresultProvides = concatMap resultToOffers layer
  , mapresultAdjusted = Just adjustedMap
  , mapresultBadges = concatMap resultToBadges layer
    <> resultToBadges generalResult
  }
  where
    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 ->
      let
        -- before linting, append the group's top-level name to that of sublayers
        results = take (length sublayers)
                  $ checkLayerRec config depth $ sublayers
                  <&> \l -> l { layerName = layerName parent <> "/" <> layerName l }
        -- get the original sublayer names
        names = fmap layerName sublayers
        -- pass the adjusted sublayers on to linting the parent layer,
        -- but restore the actual names of sublayers
        result = runLintWriter config
            (parent { layerLayers = Just
                     $ zipWith (\n l -> (resultToAdjusted l) { layerName = n })
                     names results
                   }
            ) depth checkLayer
      in (result,results)



-- human-readable lint output, e.g. for consoles
instance PrettyPrint (Level, MapResult) 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 :: HasName a => (MapResult -> Map Hint [a]) -> [Text]
      prettyLints getter = fmap
        (\(h, cs) -> prettyprint h
          <> "\n    (in "
          -- foldl :: ((length of current line, acc) -> next ctxt -> list) -> ...
          <> 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, "") (fmap getName cs))
          <> ")\n")
        (toList . getter $ mapResult)

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