diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index d6a7bd563ab7da8f0df402a4c0910a7f45a62b9e..001185755f5940378598ed2402f71df446a1bef8 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -23,6 +23,8 @@ import Data.Map.Strict (mapKeys, (\\))
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
+import Dirgraph (invertGraph, resultToGraph,
+ unreachableFrom)
import GHC.Generics (Generic)
import LintConfig (LintConfig', configMaxLintLevel)
import Paths (normalise, normaliseWithFrag)
@@ -30,8 +32,8 @@ import System.Directory.Extra (doesFileExist)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
-import Types (Dep (Local, LocalMap), Level (..),
- hintLevel)
+import Types (Dep (Local, LocalMap), Hint (Hint),
+ Level (..), hintLevel)
import Util (PrettyPrint (prettyprint))
@@ -132,39 +134,44 @@ instance PrettyPrint MissingDep where
T.intercalate "," $ map T.pack n
-instance Semigroup DirResult where
- a <> b = DirResult
- { dirresultMaps = dirresultMaps a <> dirresultMaps b
- , dirresultDeps = dirresultDeps a <> dirresultDeps b
- , dirresultMissingAssets =
- dirresultMissingAssets a <> dirresultMissingAssets b
- }
-
-instance Monoid DirResult where
- mempty = DirResult
- { dirresultMaps = mempty
- , dirresultDeps = mempty
- , dirresultMissingAssets = mempty
- }
-
-
--- | The nice function to check an entire repository with.
--- gets a prefix (i.e. the bare path to the repository) and
--- a root (i.e. the name of the file containing the entrypoint
--- map within that file)
-recursiveCheckDir :: LintConfig' -> FilePath -> FilePath -> IO DirResult
+-- | check an entire repository
+recursiveCheckDir
+ :: LintConfig'
+ -> FilePath
+ -- ^ the repository's prefix (i.e. path to its directory)
+ -> FilePath
+ -- ^ the repository's entrypoint (filename of a map, from the repo's root)
+ -> IO DirResult
recursiveCheckDir config prefix root = do
- linted <- recursiveCheckDir' config prefix [root] mempty mempty
- mAssets <- missingAssets prefix linted
- pure $ linted <> mempty { dirresultDeps = missingDeps root linted
- , dirresultMissingAssets = mAssets
- }
+ maps <- recursiveCheckDir' config prefix [root] mempty
+
+ -- maps that don't have (local) ways back to the main entrypoint
+ let nowayback =
+ unreachableFrom root
+ . invertGraph
+ . resultToGraph
+ $ maps
+
+ -- inject warnings for maps that have no way back to the entrypoint
+ let maps' = flip mapWithKey maps $ \path res ->
+ if path `elem` nowayback
+ then res { mapresultGeneral =
+ Hint Warning ("Cannot go back to " <> T.pack root <> " from this map.")
+ : mapresultGeneral res
+ }
+ else res
+
+ mAssets <- missingAssets prefix maps'
+ pure $ DirResult { dirresultDeps = missingDeps root maps'
+ , dirresultMissingAssets = mAssets
+ , dirresultMaps = maps'
+ }
-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
-missingDeps :: FilePath -> DirResult -> [MissingDep]
-missingDeps entrypoint res =
+missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep]
+missingDeps entrypoint maps =
let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial
in M.foldMapWithKey (\f n -> [MissingDep f n]) simple
where
@@ -173,7 +180,7 @@ missingDeps entrypoint res =
used = M.fromList
$ M.foldMapWithKey
(\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
- (dirresultMaps res)
+ maps
where extractLocalDeps prefix = \case
LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name
_ -> Nothing
@@ -182,15 +189,14 @@ missingDeps entrypoint res =
defined = setFromList
$ M.foldMapWithKey
(\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
- (dirresultMaps res)
+ maps
-- each map file is an entrypoint by itself
- trivial = mapKeys T.pack $ void (dirresultMaps res)
+ trivial = mapKeys T.pack $ void maps
--- | Checks if all assets found (contained in the map's lints)
--- actually exist where they should exist
-missingAssets :: FilePath -> DirResult -> IO [MissingAsset]
-missingAssets prefix res =
- mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList . dirresultMaps $ res) <&> fold
+-- | Checks if all assets referenced in the result actually exist as files
+missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset]
+missingAssets prefix maps =
+ mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold
where missingOfMap (path, mapres) = mapMaybeM
(\case Local relpath ->
let asset = normalise (takeDirectory path) relpath
@@ -201,13 +207,17 @@ missingAssets prefix res =
(mapresultDepends mapres)
--- | The less-nice function for checking an entire repository.
---
--- Strictly speaking it probably doesn't need to have `done` and
--- `acc` since they are essentially the same thing, but doing it
--- like this seemed convenient at the time
-recursiveCheckDir' :: LintConfig' -> FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
-recursiveCheckDir' config prefix paths done acc = do
+-- | recursive checking of all maps in a repository
+recursiveCheckDir'
+ :: LintConfig'
+ -> FilePath
+ -- ^ the repo's directory
+ -> [FilePath]
+ -- ^ paths of maps yet to check
+ -> Map FilePath MapResult
+ -- ^ accumulator for map results
+ -> IO (Map FilePath MapResult)
+recursiveCheckDir' config prefix paths acc = do
-- lint all maps in paths. The double fmap skips maps which cause IO errors
-- (in which case loadAndLintMap returns Nothing); appropriate warnings will
@@ -218,27 +228,21 @@ recursiveCheckDir' config prefix paths done acc = do
in mapMaybeM lintPath paths
- let mapdeps = concatMap
- (\(m,lintresult) ->
- let ps = mapMaybe
- (\case {LocalMap p -> Just p; _ -> Nothing})
- (mapresultDepends lintresult)
- 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 <> mempty { dirresultMaps = M.fromList lints }
- -- Tail recursion!
+ let mapdeps = setFromList (concatMap extractDeps lints)
+ where extractDeps (mappath, lintresult) =
+ fmap (FP.normalise . normalise (takeDirectory mappath))
+ . mapMaybe onlyLocalMaps
+ $ mapresultDepends lintresult
+ onlyLocalMaps = \case
+ LocalMap p -> Just p
+ _ -> Nothing
+
+ let acc' = acc <> M.fromList lints
+
+ -- newly found maps that still need to be checked
+ let unknowns = listFromSet $ M.difference mapdeps acc
+
+ -- no further maps? return acc'. Otherwise, recurse
case unknowns of
[] -> pure acc'
- _ -> recursiveCheckDir' config prefix unknowns knowns acc'
+ _ -> recursiveCheckDir' config prefix unknowns acc'
diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0931ea047ea6d3aff64252ac99a2fea25d639af7
--- /dev/null
+++ b/lib/Dirgraph.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- | Simple directed graphs, for dependency checking
+module Dirgraph where
+
+
+import CheckMap (MapResult (mapresultDepends))
+import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey)
+import qualified Data.Map.Strict as M
+import Data.Set (Set, (\\))
+import qualified Data.Set as S
+import Paths (normalise)
+import Types (Dep (LocalMap))
+import Witherable (mapMaybe)
+
+-- | a simple directed graph
+type Graph a = Map a (Set a)
+
+nodes :: Graph a -> Set a
+nodes = M.keysSet
+
+-- | simple directed graph of exits
+resultToGraph :: Map FilePath MapResult -> Graph FilePath
+resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends)
+ where onlyLocalMaps = \case
+ LocalMap path -> Just (normalise "" path)
+ _ -> Nothing
+
+-- | invert edges of a directed graph
+invertGraph :: (Eq a, Ord a) => Graph a -> Graph a
+invertGraph graph = mapWithKey collectFroms graph
+ where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph
+ select to from elems = if to `elem` elems then Just from else Nothing
+
+-- | all nodes reachable from some entrypoint
+reachableFrom :: Ord a => a -> Graph a -> Set a
+reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint)
+ where recursive seen current
+ | null current = seen
+ | otherwise = recursive (S.union seen current) (next \\ seen)
+ where next = S.unions
+ . S.fromList -- for some reason set is not filterable?
+ . mapMaybe (`M.lookup` graph)
+ . S.toList
+ $ current
+
+unreachableFrom :: Ord a => a -> Graph a -> Set a
+unreachableFrom entrypoint graph =
+ nodes graph \\ reachableFrom entrypoint graph
diff --git a/walint.cabal b/walint.cabal
index b1c06cab85040b7cf6bfe03c03300181721dcd30..98ba65451b558d80dd2dcbbb5aecac2fc90dbc27 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -40,6 +40,7 @@ library
LintConfig
Badges
LayerData
+ Dirgraph
build-depends: base,
aeson,
bytestring,
@@ -52,7 +53,8 @@ library
filepath,
getopt-generics,
regex-tdfa,
- extra
+ extra,
+ witherable
-- TODO: move more stuff into lib, these dependencies are silly
executable walint