nicer json output which leaks less haskell names

4 files changed, 56 insertions, 40 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index cd8f5ab..2a35c12 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -3,19 +3,17 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
 
 -- | Module that contains high-level checking for an entire directory
-{-# LANGUAGE TupleSections     #-}
 module CheckDir (recursiveCheckDir)  where
 
 import           CheckMap              (MapResult (mapresultProvides),
                                         loadAndLintMap, mapresultDepends)
 import           Control.Monad         (void)
+import           Control.Monad.Extra   (mapMaybeM)
 import           Data.Aeson            (ToJSON, (.=))
 import qualified Data.Aeson            as A
-import           Data.Bifunctor        (bimap)
-import           Data.Foldable         (fold)
-import           Data.Functor          ((<&>))
 import           Data.Map              (Map)
 import qualified Data.Map              as M
 import           Data.Map.Strict       (mapKeys, (\\))
@@ -30,6 +28,7 @@ import           System.FilePath.Posix (takeDirectory)
 import           Types                 (Dep (LocalMap), Level)
 import           Util                  (PrettyPrint (prettyprint))
 
+
 -- based on the startling observation that Data.Map has lower complexity
 -- for difference than Data.Set, but the same complexity for fromList
 type Set a = Map a ()
@@ -103,7 +102,7 @@ recursiveCheckDir prefix root = do
 -- maps are referenced but do not actually exist.
 missingDeps :: DirResult -> [MissingDep]
 missingDeps res =
-  let simple = used \\ M.union defined trivial
+  let simple = M.insert "main.json" [] used \\ M.union defined trivial
   in M.foldMapWithKey (\f n -> [MissingDep f n]) simple
   where
     -- which maps are linked somewhere?
@@ -133,18 +132,20 @@ missingDeps res =
 recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
 recursiveCheckDir' prefix paths done acc = do
 
-  -- lint all maps in paths
+  -- lint all maps in paths. The double fmap skips maps which cause IO errors
+  -- (in which case loadAndLintMap returns Nothing); appropriate warnings will
+  -- show up later during dependency checks
   lints <-
-    let lintPath p = loadAndLintMap (prefix </> p) depth <&> (p,)
+    let lintPath p = fmap (fmap (p,)) (loadAndLintMap (prefix </> p) depth)
           where depth = length (splitPath p) - 1
-    in mapM lintPath paths
+    in mapMaybeM lintPath paths
 
 
   let mapdeps = concatMap
        (\(m,res) ->
           let ps = mapMaybe
                 (\case {LocalMap p -> Just p; _ -> Nothing})
-                (mapresultDepends res)
+                (mapresultDepends $ res)
           in map (FP.normalise . normalise (takeDirectory m)) ps
        )
        lints
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 176e3d5..49dcd2e 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -8,23 +8,26 @@
 -- | Module that contains the high-level checking functions
 module CheckMap (loadAndLintMap, MapResult(..)) where
 
-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           GHC.Generics (Generic)
+import           Data.Aeson       (ToJSON)
+import qualified Data.Aeson       as A
+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           GHC.Generics     (Generic)
 
 
-import           LintWriter   (LintResult (..), LintWriter, askContext,
-                               filterLintLevel, lintToDep, resultToDeps,
-                               resultToLints, resultToOffers, runLintWriter)
-import           Properties   (checkLayerProperty, checkMap)
-import           Tiled2       (Layer (layerName, layerProperties),
-                               Tiledmap (tiledmapLayers), loadTiledmap)
-import           Types        (Dep, Level (..), Lint (..), hint, lintLevel)
-import           Util         (PrettyPrint (prettyprint), prettyprint)
+import           Data.Aeson.Types ((.=))
+import           LintWriter       (LintResult (..), LintWriter, askContext,
+                                   filterLintLevel, lintToDep, resultToDeps,
+                                   resultToLints, resultToOffers, runLintWriter)
+import           Properties       (checkLayerProperty, checkMap)
+import           Tiled2           (Layer (layerName, layerProperties),
+                                   LoadResult (..), Tiledmap (tiledmapLayers),
+                                   loadTiledmap)
+import           Types            (Dep, Level (..), Lint (..), hint)
+import           Util             (PrettyPrint (prettyprint), prettyprint)
 
 
 
@@ -34,16 +37,23 @@ data MapResult = MapResult
   , mapresultGeneral  :: [Lint]
   , mapresultDepends  :: [Dep]
   , mapresultProvides :: [Text]
-  } deriving (Generic, ToJSON)
-
+  } deriving (Generic)
 
+instance ToJSON MapResult where
+  toJSON res = A.object
+    [ "layer" .= mapresultLayer res
+    , "general" .= mapresultGeneral res
+    -- TODO: not sure if these are necessary of even useful
+    , "depends" .= mapresultDepends res
+    , "provides" .= mapresultProvides res
+    ]
 
 -- | this module's raison d'être
 -- Lints the map at `path`, and limits local links to at most `depth`
 -- layers upwards in the file hierarchy
-loadAndLintMap :: FilePath -> Int -> IO MapResult
+loadAndLintMap :: FilePath -> Int -> IO (Maybe MapResult)
 loadAndLintMap path depth = loadTiledmap path >>= pure . \case
-    Left err -> MapResult
+    DecodeErr err -> Just $ MapResult
       { mapresultLayer = Nothing
       , mapresultDepends = []
       , mapresultProvides = []
@@ -52,8 +62,9 @@ loadAndLintMap path depth = loadTiledmap path >>= pure . \case
           path <> ": Fatal: " <> err
         ]
       }
-    Right waMap ->
-      runLinter waMap depth
+    IOErr err -> Nothing
+    Loaded waMap ->
+      Just (runLinter waMap depth)
 
 -- | lint a loaded map
 runLinter :: Tiledmap -> Int -> MapResult
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index a729083..7e462cc 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -441,11 +441,14 @@ instance ToJSON Tiledmap where
                                , "nextobjectid"    .= tiledmapNextobjectid
                                ]
 
+data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String
 
 -- | Load a Tiled map from the given 'FilePath'.
-loadTiledmap :: FilePath -> IO (Either String Tiledmap)
+loadTiledmap :: FilePath -> IO LoadResult
 loadTiledmap path = do
   res <- try (BS.readFile path)
   pure $ case res of
-    Right file -> mapLeft ("Json decode error or not a Tiled map: " <>) . eitherDecode . LB.fromStrict $ file
-    Left (err :: SomeException) -> Left $ "IO Error: " <> show err
+    Right file ->  case eitherDecode . LB.fromStrict $ file of
+      Left err  -> DecodeErr err
+      Right map -> Loaded map
+    Left (err :: SomeException) -> IOErr $ show err
diff --git a/lib/Types.hs b/lib/Types.hs
index fd2bd20..c39297f 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -26,7 +26,7 @@ import           WithCli.Pure              (Argument (argumentType, parseArgumen
 -- | Levels of errors and warnings, collectively called
 -- "Hints" until I can think of some better name
 data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
-  deriving (Show, Generic, ToJSON, Ord, Eq, A.FromJSON)
+  deriving (Show, Generic, Ord, Eq, ToJSON)
 
 instance Argument Level where
   argumentType Proxy = "Lint Level"
@@ -54,7 +54,7 @@ data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
 data Hint = Hint
   { hintLevel :: Level
   , hintMsg   :: Text
-  } deriving (Generic, ToJSON)
+  } deriving (Generic)
 
 -- | shorter constructor (called hint because (a) older name and
 -- (b) lint also exists and is monadic)
@@ -75,13 +75,14 @@ instance PrettyPrint Lint where
     "  Info: map offers entrypoint " <> prettyprint dep
 
 instance ToJSON Lint where
-  toJSON (Lint l) = toJSON l
+  toJSON (Lint (Hint l m)) = A.object
+    [ "msg" .= m, "level" .= l ]
   toJSON (Depends dep) = A.object
-    [ "hintMsg" .= prettyprint dep
-    , "hintLevel" .= A.String "Dependency Info" ]
+    [ "msg" .= prettyprint dep
+    , "level" .= A.String "Dependency Info" ]
   toJSON (Offers l) = A.object
-    [ "hintMsg" .= prettyprint l
-    , "hintLevel" .= A.String "Entrypoint Info" ]
+    [ "msg" .= prettyprint l
+    , "level" .= A.String "Entrypoint Info" ]
 
 instance ToJSON Dep where
   toJSON  = \case