diff options
| -rw-r--r-- | lib/CheckDir.hs | 76 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 12 | ||||
| -rw-r--r-- | lib/Paths.hs | 17 | ||||
| -rw-r--r-- | lib/Properties.hs | 2 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 39 | ||||
| -rw-r--r-- | src/Main.hs | 4 | ||||
| -rw-r--r-- | tiled-hs.cabal | 1 |
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 |