diff options
| -rw-r--r-- | lib/CheckMap.hs | 47 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 11 | ||||
| -rw-r--r-- | src/Main.hs | 9 |
3 files changed, 44 insertions, 23 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index af80295..97e6a8c 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -1,36 +1,54 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -- | Module that contains the high-level checking functions -module CheckMap where +module CheckMap (loadAndLintMap) where +import Control.Monad.Trans.Writer (WriterT (runWriterT)) +import Data.Aeson (ToJSON) +import Data.Map (Map, fromList, toList) 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) + LintResult (..), LintWriter, hint) import Properties (checkProperty) -import Tiled2 +import Tiled2 (Layer (layerName, layerProperties), + Tiledmap (tiledmapLayers), + loadTiledmap) import Util (showText) --- | What this linter produces +-- | What this linter produces: lints for a single map data MapResult a = MapResult - { mapresultLayer :: Map Text (LintResult a) + { mapresultLayer :: Maybe (Map Text (LintResult a)) , mapresultGeneral :: [Hint] } deriving (Generic, ToJSON) --- | the main thing. runs the linter and everything + + +-- | this module's raison d'être +loadAndLintMap :: FilePath -> IO (MapResult ()) +loadAndLintMap path = loadTiledmap path >>= pure . \case + Left err -> MapResult + { mapresultLayer = Nothing + , mapresultGeneral = + [ hint Fatal . T.pack $ + path <> ": parse error (probably invalid json/not a tiled map): " <> err + ] + } + Right waMap -> + runLinter waMap + +-- | lint a loaded map runLinter :: Tiledmap -> MapResult () runLinter tiledmap = MapResult - { mapresultLayer = layer + { mapresultLayer = Just layer , mapresultGeneral = [] -- no general lints for now } where @@ -47,12 +65,15 @@ checkLayer 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 + show mapResult = concat $ prettyGeneral <> prettyLayer where + -- TODO: this can be simplified further prettyLayer :: [String] prettyLayer = mapMaybe (\(name, lints) -> T.unpack <$> showResult name lints) - (toList . mapresultLayer $ mapResult) + (maybe [] toList . mapresultLayer $ mapResult) + prettyGeneral :: [String] + prettyGeneral = show <$> mapresultGeneral mapResult -- TODO: possibly expand this to something more detailed? diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index ca7ff08..8e45812 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -10,20 +10,23 @@ import Control.Monad.Trans.Maybe () import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell), WriterT) import Data.Aeson (ToJSON (toJSON)) -import Data.Text (Text) +import Data.Text (Text, unpack) 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 +data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal deriving (Show, Generic, ToJSON) -- | a hint comes with an explanation (and a level) data Hint = Hint { hintLevel :: Level , hintMsg :: Text } - deriving (Show, Generic, ToJSON) + deriving (Generic, ToJSON) + +instance Show Hint where + show Hint { hintMsg, hintLevel } = + show hintLevel <> ": " <> unpack hintMsg -- shorter constructor hint :: Level -> Text -> Hint diff --git a/src/Main.hs b/src/Main.hs index f0af6c1..7884cf9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} @@ -8,14 +9,13 @@ module Main where import Data.Maybe (fromMaybe) import WithCli -import CheckMap (runLinter) +import CheckMap (loadAndLintMap) 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 -- | the options this cli tool can take data Options = Options @@ -39,10 +39,7 @@ main = withCli run run :: Options -> IO () run options = do - -- TODO: what if parsing fails and we get Left err? - Right waMap <- loadTiledmap $ fromMaybe "example.json" (inpath options) - - let lints = runLinter waMap + lints <- loadAndLintMap (fromMaybe "example.json" (inpath options)) if json options then printLB |