Skip to content
Snippets Groups Projects
Select Git revision
1 result Searching

models.py

Blame
  • Forked from uffd / uffd
    Source project has a limited visibility.
    CheckMap.hs 4.11 KiB
    {-# LANGUAGE DeriveAnyClass    #-}
    {-# LANGUAGE DeriveGeneric     #-}
    {-# LANGUAGE LambdaCase        #-}
    {-# LANGUAGE NamedFieldPuns    #-}
    {-# LANGUAGE OverloadedStrings #-}
    
    -- | Module that contains the high-level checking functions
    module CheckMap (loadAndLintMap) where
    
    import           Control.Monad.Trans.Writer (WriterT (runWriterT))
    import           Data.Aeson                 (ToJSON)
    import           Data.Map                   (Map, fromList, toList)
    import           Data.Maybe                 (mapMaybe)
    import           Data.Text                  (Text)
    import qualified Data.Text                  as T
    import qualified Data.Vector                as V
    import           GHC.Generics               (Generic)
    
    import           LintWriter                 (LintResult (..), LintWriter,
                                                 lintResultToDeps, lintToDep,
                                                 runLintWriter)
    import           Properties                 (checkLayerProperty, checkMap)
    import           Tiled2                     (Layer (layerName, layerProperties),
                                                 Tiledmap (tiledmapLayers),
                                                 loadTiledmap)
    import           Types                      (Dep, Level (..), Lint (..), hint,
                                                 lintLevel)
    import           Util                       (PrettyPrint (prettyprint),
                                                 prettyprint)
    
    
    -- | What this linter produces: lints for a single map
    data MapResult a = MapResult
      { mapresultLayer   :: Maybe (Map Text (LintResult a))
      , mapresultGeneral :: [Lint]
      , mapresultDepends :: [Dep]
      } deriving (Generic, ToJSON)
    
    
    
    -- | this module's raison d'être
    loadAndLintMap :: FilePath -> IO (MapResult ())
    loadAndLintMap path = loadTiledmap path >>= pure . \case
        Left err -> MapResult
          { mapresultLayer = Nothing
          , mapresultDepends = []
          , mapresultGeneral =
            [ hint Fatal . T.pack $
              path <> ": parse error (probably invalid json/not a tiled map): " <> err
            ]
          }
        Right waMap ->
          runLinter waMap
    
    -- | lint a loaded map
    runLinter :: Tiledmap -> MapResult ()
    runLinter tiledmap = MapResult
      { mapresultLayer = Just layerMap
      , mapresultGeneral = generalLints  -- no general lints for now
      , mapresultDepends = concatMap (lintResultToDeps . snd) layer
        <> mapMaybe lintToDep generalLints
      }
      where
        layerMap :: Map Text (LintResult ())
        layerMap = fromList layer
        layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
          where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
    
        -- lints collected from properties
        generalLints = runLintWriter (checkMap tiledmap)