From e68d652323e454abf7e6c01ecedd919859cf9274 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 30 Sep 2021 14:01:25 +0200 Subject: nicer json output which leaks less haskell names --- lib/CheckDir.hs | 19 ++++++++++--------- lib/CheckMap.hs | 53 ++++++++++++++++++++++++++++++++--------------------- lib/Tiled2.hs | 9 ++++++--- lib/Types.hs | 15 ++++++++------- 4 files changed, 56 insertions(+), 40 deletions(-) (limited to 'lib') 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 -- cgit v1.2.3