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 +++++++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 68 insertions(+), 11 deletions(-)

(limited to 'lib/CheckDir.hs')

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.
 --
-- 
cgit v1.2.3