diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 74 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 40 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 85 | ||||
| -rw-r--r-- | tiled-hs.cabal | 14 |
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 |