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 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/LintWriter.hs | 40 +++++++++++++++++++++--------- lib/Tiled2.hs | 2 +- 3 files changed, 103 insertions(+), 13 deletions(-) create mode 100644 lib/CheckMap.hs (limited to 'lib') 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” -- cgit v1.2.3