some simple graph algorithms

this just checks for maps from which it's impossible to reach
`main.json`, and then gives a warning. Properly it should check if these
maps have an exit to outside the repository (in which case it may give a
suggestion, and an error otherwise).

Also, redid some of the CheckDir code. No idea what that mess was, but
it's marginally nicer now.

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
+-- | 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
+  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
 
-
--- | 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
-recursiveCheckDir config prefix root = do
-  linted <- recursiveCheckDir' config prefix [root] mempty mempty
-  mAssets <- missingAssets prefix linted
-  pure $ linted <> mempty { dirresultDeps = missingDeps root linted
+  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'

lib/Dirgraph.hs

+{-# 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

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