From ca8552c4eb69b2b8267fe0046320bccf9f547b52 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 30 Sep 2021 02:02:29 +0200
Subject: 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.
---
lib/CheckDir.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++++--------
lib/CheckMap.hs | 11 +++++---
lib/LintWriter.hs | 12 +++++++++
lib/Paths.hs | 7 ++++-
lib/Properties.hs | 5 +++-
lib/Types.hs | 13 ++++++---
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
--
cgit v1.2.3