From 7a9226d84cf9dde33d0fc3e7852a22c36ab1c39b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 Sep 2021 23:18:14 +0200
Subject: input options, output json

input options are mostly dummies for now, but some work (e.g. --inpath
and --json). Lints can now be optionally printed as json to be
reasonably machine-readable (and the json can be pretty-printed to make
it human-readable again …).
---
 lib/CheckMap.hs | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 74 insertions(+)
 create mode 100644 lib/CheckMap.hs

(limited to 'lib/CheckMap.hs')

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
-- 
cgit v1.2.3