summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/CheckDir.hs19
-rw-r--r--lib/CheckMap.hs53
-rw-r--r--lib/Tiled2.hs9
-rw-r--r--lib/Types.hs15
-rw-r--r--tiled-hs.cabal3
5 files changed, 58 insertions, 41 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
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index 05ba0eb..84f8a4b 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -45,7 +45,8 @@ library
either,
filepath,
getopt-generics,
- regex-tdfa ^>= 1.3.1.1
+ regex-tdfa ^>= 1.3.1.1,
+ extra
-- TODO: move more stuff into lib, these dependencies are silly
executable tiled-hs