Skip to content
Snippets Groups Projects
Select Git revision
  • ee73be2822adeea897311eb8caac93291845ff02
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

Properties.hs

Blame
  • 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)
    
    
    -- | collect lints on a single map layer
    checkLayer :: Layer -> LintWriter ()
    checkLayer layer =
      mapM_ (checkLayerProperty layer) (layerProperties layer)
    
    -- human-readable lint output, e.g. for consoles
    instance PrettyPrint a => PrettyPrint (MapResult a) where
      prettyprint mapResult = T.concat $ prettyGeneral <> prettyLayer
        where
          -- TODO: this can be simplified further
          prettyLayer :: [Text]
          prettyLayer = mapMaybe
            (uncurry showResult)
            (maybe [] toList . mapresultLayer $ mapResult)
          prettyGeneral :: [Text]
          prettyGeneral = flip (<>) "\n" . prettyprint <$> mapresultGeneral mapResult
    
    
    -- TODO: possibly expand this to something more detailed?
    showContext :: Text -> Text
    showContext ctxt = " (in layer " <> ctxt <> ")\n"
    
    -- | pretty-printer for a LintResult. Isn't an instance of PrettyPrint since
    -- it needs to know about the result's context (yes, there could be
    -- a wrapper type for that – but I wasn't really in the mood)
    showResult :: Text -> LintResult a -> Maybe Text
    showResult ctxt (LintResult res) = case res of
      Left hint        -> Just $ "Fatal: " <> prettyprint hint
      Right (_, [])    -> Nothing
      Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints)
      where
        -- TODO: make the "log level" configurable
        showHint hint = case lintLevel hint of
          Info -> Nothing
          _    -> Just $ prettyprint hint <> ctxtHint
        ctxtHint = showContext ctxt