simple map-map link dependency checking

This is purely based on a set difference, i.e. it won't catch stupid
things like a map linking to itself, a map link going only one-way, etc.

Also, it only handles map links; it doesn't check if all ressource files
referenced by a map actually exist.

6 files changed, 106 insertions, 21 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index ab231b9..cd8f5ab 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -3,27 +3,31 @@
 {-# 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, loadAndLintMap,
-                                        mapresultDepends)
-import           Data.Aeson            (ToJSON)
+import           CheckMap              (MapResult (mapresultProvides),
+                                        loadAndLintMap, mapresultDepends)
+import           Control.Monad         (void)
+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, (\\))
 import           Data.Maybe            (mapMaybe)
 import           Data.Text             (Text)
 import qualified Data.Text             as T
 import           GHC.Generics          (Generic)
-import           Paths                 (normalise)
+import           Paths                 (normalise, normaliseWithFrag)
 import           System.FilePath       (splitPath, (</>))
 import qualified System.FilePath       as FP
 import           System.FilePath.Posix (takeDirectory)
-import           Types                 (Dep (LocalMap), Hint (hintLevel),
-                                        Level (Info))
+import           Types                 (Dep (LocalMap), Level)
 import           Util                  (PrettyPrint (prettyprint))
 
 -- based on the startling observation that Data.Map has lower complexity
@@ -37,17 +41,41 @@ listFromSet = map fst . M.toList
 -- | Result of linting an entire directory / repository
 data DirResult = DirResult
   { dirresultMaps :: Map FilePath MapResult
-  , dirresultDeps :: [Text]
+  , dirresultDeps :: [MissingDep]
+  } deriving (Generic)
+
+data MissingDep = MissingDep
+  { entrypoint :: Text
+  , neededBy   :: [FilePath]
   } deriving (Generic, ToJSON)
 
+instance ToJSON DirResult where
+  toJSON res = A.object
+    [ "missingDeps" .= dirresultDeps res
+    , "mapLints" .= dirresultMaps res
+    ]
+
 instance PrettyPrint (Level, DirResult) where
-  prettyprint (level, res) = T.concat
-    (map prettyLint $ M.toList $ dirresultMaps res)
+  prettyprint (level, res) = prettyMapLints <> prettyMissingDeps
     where
+      prettyMissingDeps = if not (null (dirresultDeps res))
+        then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res)
+        else ""
+      prettyMapLints = T.concat
+        (map prettyLint $ M.toList $ dirresultMaps res)
       prettyLint :: (FilePath, MapResult) -> Text
       prettyLint (p, lint) =
         "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)
 
+instance PrettyPrint MissingDep where
+  prettyprint (MissingDep f n) =
+    "  - " <> f <> " does not exist, but is required by "
+    <> prettyDependents <> "\n"
+    where
+      prettyDependents =
+        T.intercalate "," $ map T.pack n
+
+
 instance Semigroup DirResult where
   a <> b = DirResult
     { dirresultMaps = dirresultMaps a <> dirresultMaps b
@@ -66,7 +94,36 @@ instance Monoid DirResult where
 -- a root (i.e. the name of the file containing the entrypoint
 -- map within that file)
 recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
-recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty
+recursiveCheckDir prefix root = do
+  linted <- recursiveCheckDir' prefix [root] mempty mempty
+  pure $ linted <> mempty { dirresultDeps = missingDeps linted }
+
+
+-- | Given a (partially) completed DirResult, check which local
+-- maps are referenced but do not actually exist.
+missingDeps :: DirResult -> [MissingDep]
+missingDeps res =
+  let simple = used \\ M.union defined trivial
+  in M.foldMapWithKey (\f n -> [MissingDep f n]) simple
+  where
+    -- which maps are linked somewhere?
+    used :: Map Text [FilePath]
+    used = M.fromList
+      $ M.foldMapWithKey
+      (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
+      (dirresultMaps res)
+      where extractLocalDeps prefix = \case
+              LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name
+              _             -> Nothing
+    -- which are defined using startLayer?
+    defined :: Set Text
+    defined = setFromList
+      $ M.foldMapWithKey
+      (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
+      (dirresultMaps res)
+    -- each map file is an entrypoint by itself
+    trivial = mapKeys T.pack $ void (dirresultMaps res)
+
 
 -- | The less-nice function for checking an entire repository.
 --
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index eaeac55..176e3d5 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -19,7 +19,7 @@ import           GHC.Generics (Generic)
 
 import           LintWriter   (LintResult (..), LintWriter, askContext,
                                filterLintLevel, lintToDep, resultToDeps,
-                               resultToLints, runLintWriter)
+                               resultToLints, resultToOffers, runLintWriter)
 import           Properties   (checkLayerProperty, checkMap)
 import           Tiled2       (Layer (layerName, layerProperties),
                                Tiledmap (tiledmapLayers), loadTiledmap)
@@ -30,9 +30,10 @@ import           Util         (PrettyPrint (prettyprint), prettyprint)
 
 -- | What this linter produces: lints for a single map
 data MapResult = MapResult
-  { mapresultLayer   :: Maybe (Map Text (LintResult Layer))
-  , mapresultGeneral :: [Lint]
-  , mapresultDepends :: [Dep]
+  { mapresultLayer    :: Maybe (Map Text (LintResult Layer))
+  , mapresultGeneral  :: [Lint]
+  , mapresultDepends  :: [Dep]
+  , mapresultProvides :: [Text]
   } deriving (Generic, ToJSON)
 
 
@@ -45,6 +46,7 @@ loadAndLintMap path depth = loadTiledmap path >>= pure . \case
     Left err -> MapResult
       { mapresultLayer = Nothing
       , mapresultDepends = []
+      , mapresultProvides = []
       , mapresultGeneral =
         [ hint Fatal . T.pack $
           path <> ": Fatal: " <> err
@@ -60,6 +62,7 @@ runLinter tiledmap depth = MapResult
   , mapresultGeneral = generalLints  -- no general lints for now
   , mapresultDepends = concatMap (resultToDeps . snd) layer
     <> mapMaybe lintToDep generalLints
+  , mapresultProvides = concatMap (resultToOffers . snd) layer
   }
   where
     layerMap :: Map Text (LintResult Layer)
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index e704a3c..cdec972 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -53,6 +53,11 @@ lintToDep = \case
   Depends dep -> Just dep
   _           -> Nothing
 
+lintToOffer :: Lint -> Maybe Text
+lintToOffer = \case
+  Offers frag -> Just frag
+  _           -> Nothing
+
 filterLintLevel :: Level -> [Lint] -> [Lint]
 filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l
   then Just l
@@ -61,6 +66,9 @@ filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l
 resultToDeps :: LintResult a -> [Dep]
 resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a
 
+resultToOffers :: LintResult a -> [Text]
+resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a
+
 -- | convert a lint result into a flat list of lints
 -- (throwing away information on if a single error was fatal)
 resultToLints :: LintResult a -> [Lint]
@@ -78,6 +86,10 @@ lint level = tell . (: []) . hint level
 dependsOn :: Dep -> LintWriter a
 dependsOn dep = tell . (: []) $ Depends dep
 
+offersEntrypoint :: Text -> LintWriter a
+offersEntrypoint = tell . (: []) . Offers
+
+
 
 info = lint Info
 suggest = lint Suggestion
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 5044673..af66e77 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -35,8 +35,9 @@ parsePath text =
       else Nothing
 
 instance PrettyPrint RelPath where
-  prettyprint (Path up rest _) = ups <> rest
+  prettyprint (Path up rest frag) = ups <> rest <> fragment
     where ups = T.concat $ replicate up "../"
+          fragment = maybe mempty ("#" <>) frag
 
 -- | Normalises a path.
 --
@@ -48,3 +49,7 @@ 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
+
+normaliseWithFrag :: FilePath -> RelPath -> FilePath
+normaliseWithFrag prefix (Path i path frag) =
+  normalise prefix (Path (i+1) path frag) <> T.unpack (maybe mempty ("#" <>) frag)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 86acda9..877afe1 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -13,7 +13,8 @@ import           Tiled2        (Layer (..), Property (..), PropertyValue (..),
 import           Util          (layerIsEmpty, prettyprint)
 
 import           LintWriter    (LintWriter, askContext, askFileDepth, complain,
-                                dependsOn, forbid, suggest, warn)
+                                dependsOn, forbid, offersEntrypoint, suggest,
+                                warn)
 import           Paths         (RelPath (..), parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
 
@@ -142,6 +143,8 @@ checkLayerProperty p@(Property name _value) = case name of
         else unwrapPath link (dependsOn . LocalMap)
     "startLayer" -> do
       forbidEmptyLayer
+      layer <- askContext
+      offersEntrypoint $ layerName layer
       unwrapBool p $ \case
         True  -> pure ()
         False -> complain "startLayer must be set to true"
diff --git a/lib/Types.hs b/lib/Types.hs
index b609012..fd2bd20 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -45,11 +45,11 @@ instance HasArguments Level where
 
 -- | a hint comes with an explanation (and a level), or is a dependency
 -- (in which case it'll be otherwise treated as an info hint)
-data Lint = Depends Dep | Lint Hint
+data Lint = Depends Dep | Offers Text | Lint Hint
 
 -- | TODO: add a reasonable representation of possible urls
 data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
-  deriving (Generic)
+  deriving (Generic, Ord, Eq)
 
 data Hint = Hint
   { hintLevel :: Level
@@ -63,20 +63,25 @@ hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
 
 -- | dependencies just have level Info
 lintLevel :: Lint -> Level
-lintLevel (Lint h)    = hintLevel h
-lintLevel (Depends _) = Info
+lintLevel (Lint h) = hintLevel h
+lintLevel _        = Info
 
 instance PrettyPrint Lint where
   prettyprint (Lint  Hint { hintMsg, hintLevel } ) =
     "  " <> showText hintLevel <> ": " <> hintMsg
   prettyprint (Depends dep) =
     "  Info: found dependency: " <> prettyprint dep
+  prettyprint (Offers dep) =
+    "  Info: map offers entrypoint " <> prettyprint dep
 
 instance ToJSON Lint where
   toJSON (Lint l) = toJSON l
   toJSON (Depends dep) = A.object
     [ "hintMsg" .= prettyprint dep
     , "hintLevel" .= A.String "Dependency Info" ]
+  toJSON (Offers l) = A.object
+    [ "hintMsg" .= prettyprint l
+    , "hintLevel" .= A.String "Entrypoint Info" ]
 
 instance ToJSON Dep where
   toJSON  = \case