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 …).

3 files changed, 103 insertions, 13 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
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 0146366..ca7ff08 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -1,29 +1,32 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 -- | a monad that collects warnings, outputs, etc,
 module LintWriter where
 
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Maybe (isJust, mapMaybe)
-import Control.Monad.Writer
-import Control.Monad.Trans.Maybe
+import           Control.Monad.Trans.Maybe ()
+import           Control.Monad.Writer      (MonadTrans (lift),
+                                            MonadWriter (tell), WriterT)
+import           Data.Aeson                (ToJSON (toJSON))
+import           Data.Text                 (Text)
+import           GHC.Generics              (Generic)
 
 
 -- | Levels of errors and warnings, collectively called
 -- "Hints" until I can think of some better name
 data Level = Warning | Suggestion | Info | Forbidden | Error
-  deriving Show
+  deriving (Show, Generic, ToJSON)
 
 -- | a hint comes with an explanation (and a level)
 data Hint = Hint
   { hintLevel :: Level
-  , hintMsg :: Text }
-  deriving Show
+  , hintMsg   :: Text }
+  deriving (Show, Generic, ToJSON)
 
 -- shorter constructor
+hint :: Level -> Text -> Hint
 hint level msg = Hint { hintLevel = level, hintMsg = msg }
 
 -- | a monad to collect hints. If it yields Left, then the
@@ -31,7 +34,20 @@ hint level msg = Hint { hintLevel = level, hintMsg = msg }
 -- from getting any hints at all except whatever broke it
 type LintWriter a = WriterT [Hint] (Either Hint) a
 
-type LintResult a = Either Hint (a, [Hint])
+-- this is wrapped in a newtype because Aeson is silly and wants
+-- to serialise Either as { "Right" : … } or { "Left" : … } ...
+type LintResult' a = Either Hint (a, [Hint])
+newtype LintResult a = LintResult (LintResult' a)
+
+-- better, less confusing serialisation of an Either Hint (a, [Hint]).
+-- Note that Left hint is also serialised as a list to make the resulting
+-- json schema more regular.
+instance ToJSON a => ToJSON (LintResult a) where
+  toJSON (LintResult r) = toJson' r
+    where toJson' (Left hint)        = toJSON [hint]
+          toJson' (Right (_, hints)) = toJSON hints
+
+
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter ()
@@ -49,7 +65,7 @@ complain = lint Error
 -- | converts a Maybe to an Either, with a default value for Left
 unwrap :: b -> Maybe a  -> Either b a
 unwrap hint maybe = case maybe of
-  Just a -> Right a
+  Just a  -> Right a
   Nothing -> Left hint
 
 -- | unwrap and produce a warning if the value was Nothing
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 17b2b77..bc752a5 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -140,7 +140,7 @@ data Layer = Layer { layerWidth      :: Double
                      -- ^ Column count. Same as map width for fixed-size maps.
                    , layerHeight     :: Double
                      -- ^ Row count. Same as map height for fixed-size maps.
-                   , layerName       :: String
+                   , layerName       :: Text
                      -- ^ Name assigned to this layer
                    , layerType       :: String
                      -- ^ “tilelayer”, “objectgroup”, or “imagelayer”