summaryrefslogtreecommitdiff
path: root/lib/CheckMap.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/CheckMap.hs')
-rw-r--r--lib/CheckMap.hs74
1 files changed, 74 insertions, 0 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
new file mode 100644
index 0000000..af80295
--- /dev/null
+++ b/lib/CheckMap.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Module that contains the high-level checking functions
+module CheckMap where
+
+import Data.Maybe (mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+
+import Control.Monad.Trans.Writer
+import Data.Aeson (ToJSON)
+import Data.Map (Map, fromList, toList)
+import GHC.Generics (Generic)
+import LintWriter (Hint (..), Level (..),
+ LintResult (..), LintWriter)
+import Properties (checkProperty)
+import Tiled2
+import Util (showText)
+
+-- | What this linter produces
+data MapResult a = MapResult
+ { mapresultLayer :: Map Text (LintResult a)
+ , mapresultGeneral :: [Hint]
+ } deriving (Generic, ToJSON)
+
+-- | the main thing. runs the linter and everything
+runLinter :: Tiledmap -> MapResult ()
+runLinter tiledmap = MapResult
+ { mapresultLayer = layer
+ , mapresultGeneral = [] -- no general lints for now
+ }
+ where
+ layer :: Map Text (LintResult ())
+ layer = fromList . V.toList . V.map runCheck $ tiledmapLayers tiledmap
+ where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
+
+-- | collect lints on a single map layer
+checkLayer :: Layer -> LintWriter ()
+checkLayer layer =
+ mapM_ (checkProperty layer) (layerProperties layer)
+
+
+-- this instance of show produces a reasonably human-readable
+-- list of lints that can be shown e.g. on a console
+instance Show a => Show (MapResult a) where
+ show mapResult = concat prettyLayer
+ where
+ prettyLayer :: [String]
+ prettyLayer = mapMaybe
+ (\(name, lints) -> T.unpack <$> showResult name lints)
+ (toList . mapresultLayer $ 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 Show 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 :: Show a => Text -> LintResult a -> Maybe Text
+showResult ctxt (LintResult (Left hint)) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
+showResult _ (LintResult (Right (_, []))) = Nothing
+showResult ctxt (LintResult (Right (_, hints))) = Just $ T.concat (mapMaybe showHint hints)
+ where
+ -- TODO: make the "log level" configurable
+ showHint Hint { hintMsg, hintLevel } = case hintLevel of
+ Info -> Nothing
+ _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
+ ctxtHint = showContext ctxt