From 7a9226d84cf9dde33d0fc3e7852a22c36ab1c39b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 16 Sep 2021 23:18:14 +0200
Subject: [PATCH] input options, output json
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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 +-
src/Main.hs | 85 +++++++++++++++++++++++------------------------
tiled-hs.cabal | 14 ++++----
5 files changed, 152 insertions(+), 63 deletions(-)
create mode 100644 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
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”
diff --git a/src/Main.hs b/src/Main.hs
index d820c20..f0af6c1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,57 +1,54 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Control.Monad.Trans.Maybe
-import Control.Monad.Writer
-import qualified Data.Aeson as Aeson
-import Data.Map (Map, (!?))
-import Data.Maybe (isJust, mapMaybe)
-import Data.Set (Set, fromList)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Vector (Vector)
-import qualified Data.Vector as V
-
-import LintWriter (LintWriter, LintResult, Hint(..), Level(..))
-import Properties (checkProperty)
+import Data.Maybe (fromMaybe)
+import WithCli
+
+import CheckMap (runLinter)
+import Data.Aeson (encode)
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.Lazy.Encoding as LB
+import Data.Text.Lazy as T
+import System.IO (utf8)
import Tiled2
-import Util (showText)
+-- | the options this cli tool can take
+data Options = Options
+ { inpath :: Maybe String
+ -- ^ path to input map files
+ , outpath :: Maybe String
+ -- ^ path to out directory (should be empty)
+ , allowScripts :: Bool
+ -- ^ pass --allowScripts to allow javascript in map
+ , scriptInject :: Maybe String
+ -- ^ optional filepath to javascript that should be injected
+ , json :: Bool
+ -- ^ emit json if --json was given
+ , pretty :: Bool
+ -- ^ pretty-print the json to make it human-readable
+ } deriving (Show, Generic, HasArguments)
-checkLayer :: Layer -> LintWriter ()
-checkLayer layer =
- mapM_ (checkProperty layer) (layerProperties layer)
+main :: IO ()
+main = withCli run
--- TODO: possibly expand this to something more detailed?
-showContext :: Text -> Text
-showContext ctxt = " (in layer " <> ctxt <> ")\n"
+run :: Options -> IO ()
+run options = do
+ -- TODO: what if parsing fails and we get Left err?
+ Right waMap <- loadTiledmap $ fromMaybe "example.json" (inpath options)
--- | pretty-printer for a result of WriterMaybe (currently only for errors/hints)
-showResult :: Show a => Text -> LintResult a -> Maybe Text
-showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
-showResult _ (Right (a, [])) = Nothing
-showResult ctxt (Right (a, hints)) = Just $ showHints hints
- where
- showHints hints = T.concat (mapMaybe showHint hints)
- -- TODO: make the "log level" configurable
- showHint Hint { hintMsg, hintLevel } = case hintLevel of
- Info -> Nothing
- _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
- ctxtHint = showContext ctxt
+ let lints = runLinter waMap
+ if json options
+ then printLB
+ $ if pretty options then encodePretty lints else encode lints
+ else print lints
-main :: IO ()
-main = do
- Right map <- loadTiledmap "example.json"
- -- LintWriter is a Writer transformer, so run it with runWriterT
- let lints = fmap (runWriterT . checkLayer) (tiledmapLayers map)
-
- -- well this is a bit awkward (but how to get layer names otherwise?)
- let lines = V.mapMaybe thing (tiledmapLayers map)
- where thing layer = (showResult (T.pack $ layerName layer)
- . runWriterT . checkLayer) layer
- mapM_ T.putStr lines
+-- | haskell's many string types are FUN …
+printLB :: LB.ByteString -> IO ()
+printLB = putStrLn . T.unpack . LB.decode utf8
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index 094d31b..9b7b171 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -26,6 +26,7 @@ library
ghc-options: -Wall
hs-source-dirs: lib
exposed-modules:
+ CheckMap
LintWriter
Properties
Tiled2
@@ -43,13 +44,14 @@ library
-- TODO: move more stuff into lib, these dependencies are silly
executable tiled-hs
main-is: Main.hs
+ ghc-options: -Wall
build-depends: base ^>=4.14.1.0,
- aeson,
- text,
tiled-hs,
- transformers,
- containers,
- vector,
- mtl
+ getopt-generics,
+ aeson,
+ aeson-pretty,
+ bytestring,
+ bytestring-encoding,
+ text
hs-source-dirs: src
default-language: Haskell2010
--
GitLab