summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/CheckDir.hs76
-rw-r--r--lib/CheckMap.hs12
-rw-r--r--lib/Paths.hs17
-rw-r--r--lib/Properties.hs2
-rw-r--r--lib/Tiled2.hs39
-rw-r--r--src/Main.hs4
-rw-r--r--tiled-hs.cabal1
7 files changed, 124 insertions, 27 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
new file mode 100644
index 0000000..1ca71eb
--- /dev/null
+++ b/lib/CheckDir.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Module that contains high-level checking for an entire directory
+module CheckDir (recursiveCheckDir) where
+
+import CheckMap (MapResult, loadAndLintMap, mapresultDepends)
+import Data.Aeson (ToJSON)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Generics (Generic)
+import Paths (normalise)
+import Types (Dep (LocalMap))
+import Util (PrettyPrint (prettyprint))
+
+
+data DirResult = DirResult
+ { dirresultMaps :: [MapResult]
+ , dirresultDeps :: [Text]
+ } deriving (Generic, ToJSON)
+
+
+instance PrettyPrint DirResult where
+ prettyprint res = "Here's a result:" <> T.concat (map prettyprint $ dirresultMaps res)
+
+-- 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 ()
+
+
+instance Semigroup DirResult where
+ a <> b = DirResult
+ { dirresultMaps = dirresultMaps a <> dirresultMaps b
+ , dirresultDeps = dirresultDeps a <> dirresultDeps b
+ }
+
+instance Monoid DirResult where
+ mempty = DirResult
+ { dirresultMaps = []
+ , dirresultDeps = []
+ }
+
+
+-- TODO: options?
+recursiveCheckDir :: FilePath -> IO DirResult
+recursiveCheckDir root = recursiveCheckDir' [root] mempty mempty
+
+
+recursiveCheckDir' :: [FilePath] -> Set FilePath -> DirResult -> IO DirResult
+recursiveCheckDir' paths done acc = do
+ putStrLn $ "linting " <> show paths
+ -- lint all maps in paths
+ lints <- mapM loadAndLintMap paths
+ -- get new deps
+ let deps = concatMap mapresultDepends lints
+ -- filter deps for map dependencies
+ let mapdeps =
+ map (\(LocalMap path) -> normalise path)
+ . filter (\case { LocalMap _ -> True; _ -> False })
+ $ deps
+ -- build a Map FilePath () containing all map dependencies
+ let mapmapdeps = M.fromList $ zip mapdeps (repeat ())
+ -- take difference of that with what's already done (O(m+n))
+ let unknowns = map fst . M.toList $ M.difference mapmapdeps done
+ let known = M.union done . M.fromList . zip paths $ repeat ()
+
+ let acc' = acc <> DirResult
+ { dirresultMaps = lints
+ , dirresultDeps = [] }
+ case unknowns of
+ [] -> pure acc'
+ _ -> recursiveCheckDir' unknowns known acc'
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index c03197c..8d670d5 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains the high-level checking functions
-module CheckMap (loadAndLintMap) where
+module CheckMap (loadAndLintMap, MapResult(..)) where
import Data.Aeson (ToJSON)
import Data.Map (Map, fromList, toList)
@@ -27,7 +27,7 @@ import Util (PrettyPrint (prettyprint), prettyprint)
-- | What this linter produces: lints for a single map
-data MapResult a = MapResult
+data MapResult = MapResult
{ mapresultLayer :: Maybe (Map Text (LintResult Layer))
, mapresultGeneral :: [Lint]
, mapresultDepends :: [Dep]
@@ -36,21 +36,21 @@ data MapResult a = MapResult
-- | this module's raison d'ĂȘtre
-loadAndLintMap :: FilePath -> IO (MapResult ())
+loadAndLintMap :: FilePath -> IO MapResult
loadAndLintMap path = loadTiledmap path >>= pure . \case
Left err -> MapResult
{ mapresultLayer = Nothing
, mapresultDepends = []
, mapresultGeneral =
[ hint Fatal . T.pack $
- path <> ": parse error (probably invalid json/not a tiled map): " <> err
+ path <> ": Fatal: " <> err
]
}
Right waMap ->
runLinter waMap
-- | lint a loaded map
-runLinter :: Tiledmap -> MapResult ()
+runLinter :: Tiledmap -> MapResult
runLinter tiledmap = MapResult
{ mapresultLayer = Just layerMap
, mapresultGeneral = generalLints -- no general lints for now
@@ -75,7 +75,7 @@ checkLayer = do
mapM_ checkLayerProperty (layerProperties layer)
-- human-readable lint output, e.g. for consoles
-instance PrettyPrint a => PrettyPrint (MapResult a) where
+instance PrettyPrint MapResult where
prettyprint mapResult = T.concat $ prettyGeneral <> prettyLayer
where
-- TODO: this can be simplified further
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 7750723..4dcaa53 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -11,21 +11,30 @@ import Util (PrettyPrint (prettyprint))
-- | a normalised path: a number of "upwards" steps, and
-- a path without any . or .. in it
-data RelPath = Path Int Text
- deriving (Show, Eq)
+data RelPath = Path Int Text (Maybe Text)
+ deriving (Show, Eq, Ord)
-- | horrible regex parsing for filepaths that is hopefully kinda safe
parsePath :: Text -> Maybe RelPath
parsePath text =
if rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) :: Bool
- then Just $ Path up rest
+ then Just $ Path up path fragment
else Nothing
where
(_, prefix, rest, _) =
text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text])
-- how many steps upwards in the tree?
up = length . filter (".." ==) . T.splitOn "/" $ prefix
+ parts = T.splitOn "#" rest
+ path = head parts
+ fragment = if length parts >= 2
+ then Just $ T.concat $ tail parts -- TODO!
+ else Nothing
instance PrettyPrint RelPath where
- prettyprint (Path up rest) = ups <> rest
+ prettyprint (Path up rest _) = ups <> rest
where ups = T.concat $ replicate up "../"
+
+normalise :: RelPath -> FilePath
+normalise (Path 0 path _) = T.unpack path
+normalize _ = error "not implemented yet"
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 011b5ca..86acda9 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -228,7 +228,7 @@ unwrapBool (Property name value) f = case value of
unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
unwrapPath str f = case parsePath str of
- Just p@(Path up _) -> do
+ Just p@(Path up _ _) -> do
depth <- askFileDepth
if up <= depth
then f p
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index f1cca2e..a729083 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -10,22 +10,27 @@
-- those you should read the TMX documentation at
-- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Tiled2 where
-import Control.Applicative ((<|>))
-import Control.Monad (forM)
-import Data.Aeson hiding (Object)
-import qualified Data.Aeson as A
-import Data.Aeson.Types (Parser, typeMismatch)
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.Functor ((<&>))
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import Data.Vector (Vector)
-import GHC.Exts (fromList, toList)
-import GHC.Generics (Generic)
+import Control.Applicative ((<|>))
+import Control.Exception (try)
+import Control.Exception.Base (SomeException)
+import Control.Monad (forM)
+import Data.Aeson hiding (Object)
+import qualified Data.Aeson as A
+import Data.Aeson.Types (Parser, typeMismatch)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LB
+import Data.Either.Combinators (mapLeft)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Vector (Vector)
+import GHC.Exts (fromList, toList)
+import GHC.Generics (Generic)
-- | A globally indexed identifier.
@@ -439,4 +444,8 @@ instance ToJSON Tiledmap where
-- | Load a Tiled map from the given 'FilePath'.
loadTiledmap :: FilePath -> IO (Either String Tiledmap)
-loadTiledmap = fmap eitherDecode . C8.readFile
+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
diff --git a/src/Main.hs b/src/Main.hs
index 969fa10..33db91c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -17,6 +17,7 @@ import WithCli
import CheckMap (loadAndLintMap)
import Util (printPretty)
+import CheckDir (recursiveCheckDir)
-- | the options this cli tool can take
data Options = Options
@@ -40,7 +41,8 @@ main = withCli run
run :: Options -> IO ()
run options = do
- lints <- loadAndLintMap (fromMaybe "example.json" (inpath options))
+ --lints <- loadAndLintMap (fromMaybe "example.json" (inpath options))
+ lints <- recursiveCheckDir (fromMaybe "example.json" (inpath options))
if json options
then printLB
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index 3740fd3..b4401ca 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -27,6 +27,7 @@ library
hs-source-dirs: lib
exposed-modules:
CheckMap
+ CheckDir
LintWriter
Properties
Tiled2