very naïve handling of directories

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