From bfe45dc4996537b72436f4041d0ca819aa3444e1 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Fri, 17 Sep 2021 23:50:45 +0200
Subject: [PATCH] (somewhat) reasonable representation of parse errors
This makes map loading (and parsing) part of the linter, and also makes
it return "general lints" and nothing else in case that failed.
Possibly a sum type would be nicer here, but I guess it's not really
important since everything ends up as json anyways?
---
lib/CheckMap.hs | 47 ++++++++++++++++++++++++++++++++++-------------
lib/LintWriter.hs | 11 +++++++----
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
--
GitLab