From bfe45dc4996537b72436f4041d0ca819aa3444e1 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Fri, 17 Sep 2021 23:50:45 +0200
Subject: (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 +++++++----
 2 files changed, 41 insertions(+), 17 deletions(-)

(limited to 'lib')

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
-- 
cgit v1.2.3