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

5 files changed, 152 insertions, 63 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”
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