handle all maps in entire repositories

(+ checking that paths don't run outside of respositories)

3 files changed, 96 insertions, 66 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 1ca71eb..753d5ab 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -2,35 +2,44 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
 
 -- | 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))
+import           CheckMap              (MapResult, loadAndLintMap,
+                                        mapresultDepends)
+import           Data.Aeson            (ToJSON)
+import           Data.Functor          ((<&>))
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+import           Data.Maybe            (mapMaybe)
+import           Data.Text             (Text)
+import qualified Data.Text             as T
+import           GHC.Generics          (Generic)
+import           Paths                 (normalise)
+import           System.FilePath       (splitPath, (</>))
+import qualified System.FilePath       as FP
+import           System.FilePath.Posix (takeDirectory)
+import           Types                 (Dep (LocalMap))
+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 ()
+setFromList :: Ord a => [a] -> Set a
+setFromList  = M.fromList . flip zip (repeat ())
+listFromSet :: Set a -> [a]
+listFromSet = map fst . M.toList
 
 data DirResult = DirResult
-  { dirresultMaps :: [MapResult]
+  { dirresultMaps :: Map FilePath 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 ()
-
+  prettyprint res = T.concat
+    (map (\(p,lints) -> "\nin " <> T.pack p <> ":\n" <> prettyprint lints) $ M.toList $ dirresultMaps res)
 
 instance Semigroup DirResult where
   a <> b = DirResult
@@ -40,37 +49,50 @@ instance Semigroup DirResult where
 
 instance Monoid DirResult where
   mempty = DirResult
-    { dirresultMaps = []
+    { dirresultMaps = mempty
     , dirresultDeps = []
     }
 
 
 -- TODO: options?
-recursiveCheckDir :: FilePath -> IO DirResult
-recursiveCheckDir root = recursiveCheckDir' [root] mempty mempty
+recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
+recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty
 
 
-recursiveCheckDir' :: [FilePath] -> Set FilePath -> DirResult -> IO DirResult
-recursiveCheckDir' paths done acc = do
+recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
+recursiveCheckDir' prefix 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 ()
+  lints <-
+    let lintPath p = loadAndLintMap (prefix </> p) depth <&> (p,)
+          where depth = length (splitPath p) - 1
+    in mapM lintPath paths
+
+
+  let mapdeps = concatMap
+       (\(m,res) ->
+          let ps = mapMaybe
+                (\case {LocalMap p -> Just p; _ -> Nothing})
+                (mapresultDepends res)
+          in map (FP.normalise . normalise (takeDirectory m)) ps
+       )
+       lints
+
+  -- build a Set containing all newly found dependencies, with paths
+  -- from the repository's directory, normalised not to start with ./ etc.
+  let setdeps = setFromList
+       mapdeps
+  -- that which is yet to do (O(m+n))
+  let unknowns = listFromSet $ M.difference setdeps done
+  -- that which is done
+  let knowns = M.union done $ setFromList paths
 
+  -- Monoids!
   let acc' = acc <> DirResult
-                { dirresultMaps = lints
+                { dirresultMaps = M.fromList lints
                 , dirresultDeps = [] }
+  -- Tail recursion!
   case unknowns of
     [] -> pure acc'
-    _  -> recursiveCheckDir' unknowns known acc'
+    _  -> recursiveCheckDir' prefix unknowns knowns acc'
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 8d670d5..016ec0b 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -7,22 +7,24 @@
 -- | 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           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           System.FilePath.Posix (splitPath)
 
-import           LintWriter   (LintResult (..), LintWriter, askContext,
-                               lintToDep, resultToDeps, resultToLints,
-                               runLintWriter)
-import           Properties   (checkLayerProperty, checkMap)
-import           Tiled2       (Layer (layerName, layerProperties),
-                               Tiledmap (tiledmapLayers), loadTiledmap)
-import           Types        (Dep, Level (..), Lint (..), hint)
-import           Util         (PrettyPrint (prettyprint), prettyprint)
+
+import           LintWriter            (LintResult (..), LintWriter, askContext,
+                                        lintToDep, resultToDeps, resultToLints,
+                                        runLintWriter)
+import           Properties            (checkLayerProperty, checkMap)
+import           Tiled2                (Layer (layerName, layerProperties),
+                                        Tiledmap (tiledmapLayers), loadTiledmap)
+import           Types                 (Dep, Level (..), Lint (..), hint)
+import           Util                  (PrettyPrint (prettyprint), prettyprint)
 
 
 
@@ -36,8 +38,10 @@ data MapResult = MapResult
 
 
 -- | this module's raison d'être
-loadAndLintMap :: FilePath -> IO MapResult
-loadAndLintMap path = loadTiledmap path >>= pure . \case
+-- 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 path depth = loadTiledmap path >>= pure . \case
     Left err -> MapResult
       { mapresultLayer = Nothing
       , mapresultDepends = []
@@ -47,11 +51,11 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
         ]
       }
     Right waMap ->
-      runLinter waMap
+      runLinter waMap depth
 
 -- | lint a loaded map
-runLinter :: Tiledmap -> MapResult
-runLinter tiledmap = MapResult
+runLinter :: Tiledmap -> Int -> MapResult
+runLinter tiledmap depth = MapResult
   { mapresultLayer = Just layerMap
   , mapresultGeneral = generalLints  -- no general lints for now
   , mapresultDepends = concatMap (resultToDeps . snd) layer
@@ -61,11 +65,11 @@ runLinter tiledmap = MapResult
     layerMap :: Map Text (LintResult Layer)
     layerMap = fromList layer
     layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
-      where runCheck l = (layerName l, runLintWriter l 0 checkLayer)
+      where runCheck l = (layerName l, runLintWriter l depth checkLayer)
 
     -- lints collected from properties
     generalLints =
-      resultToLints $ runLintWriter tiledmap 0 checkMap
+      resultToLints $ runLintWriter tiledmap depth checkMap
 
 
 -- | collect lints on a single map layer
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 4dcaa53..49c0295 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -4,10 +4,12 @@
 
 module Paths where
 
-import           Data.Text       (Text)
-import qualified Data.Text       as T
+import           Data.Text             (Text)
+import qualified Data.Text             as T
+import           System.FilePath       (splitPath)
+import           System.FilePath.Posix ((</>))
 import           Text.Regex.TDFA
-import           Util            (PrettyPrint (prettyprint))
+import           Util                  (PrettyPrint (prettyprint))
 
 -- | a normalised path: a number of "upwards" steps, and
 -- a path without any . or .. in it
@@ -35,6 +37,8 @@ instance PrettyPrint RelPath where
   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"
+normalise :: FilePath -> RelPath ->  FilePath
+normalise prefix (Path 0 path _) = prefix </> T.unpack path
+normalise prefix (Path i path _) =
+  concat (take (length dirs - i) dirs) </> T.unpack path
+  where dirs = splitPath prefix