diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckDir.hs | 79 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 11 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 12 | ||||
| -rw-r--r-- | lib/Paths.hs | 7 | ||||
| -rw-r--r-- | lib/Properties.hs | 5 | ||||
| -rw-r--r-- | 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 |