Use new shrink function to filter sourceunit dependencies (#319)

Changelog.md

@@ -1,5 +1,9 @@
 # Spectrometer Changelog
 
+## v2.14.4
+
+- Gradle: Fixes an issue where all dependencies would appear as direct ([#319](https://github.com/fossas/spectrometer/pull/319))
+
 ## v2.14.3
 
 - Monorepo: archive expansion now respects `--exclude-path` and `--only-path`. ([#320](https://github.com/fossas/spectrometer/pull/320))

src/Algebra/Graph/AdjacencyMap/Extra.hs

@@ -1,5 +1,7 @@
 module Algebra.Graph.AdjacencyMap.Extra (
   gtraverse,
+  shrink,
+  shrinkSingle,
 ) where
 
 import Algebra.Graph.AdjacencyMap qualified as AM
@@ -17,3 +19,27 @@ gtraverse f = fmap mkAdjacencyMap . traverse (\(a, xs) -> (,) <$> f a <*> traver
   where
     mkAdjacencyMap :: Ord c => [(c, [c])] -> AM.AdjacencyMap c
     mkAdjacencyMap = AM.fromAdjacencySets . fmap (fmap Set.fromList)
+
+-- | Filter vertices in an AdjacencyMap, preserving the overall structure by rewiring edges through deleted vertices.
+--
+-- For example, given the graph @1 -> 2 -> 3 -> 4@ and applying @shrink (/= 3)@, we return the graph
+-- @1 -> 2 -> 4@
+shrink :: Ord a => (a -> Bool) -> AM.AdjacencyMap a -> AM.AdjacencyMap a
+shrink f gr = foldr shrinkSingle gr filteredOutVertices
+  where
+    filteredOutVertices = filter (not . f) (AM.vertexList gr)
+
+-- | Delete a vertex in an AdjacencyMap, preserving the overall structure by rewiring edges through the delted vertex.
+--
+-- For example, given the graph @1 -> 2 -> 3 -> 4@ and applying @shrinkSingle 3@, we return the graph
+-- @1 -> 2 -> 4@
+shrinkSingle :: forall a. Ord a => a -> AM.AdjacencyMap a -> AM.AdjacencyMap a
+shrinkSingle vert gr = AM.overlay (AM.removeVertex vert gr) inducedEdges
+  where
+    inducedEdges :: AM.AdjacencyMap a
+    inducedEdges =
+      AM.edges
+        [ (pre, post)
+        | pre <- Set.toList (AM.preSet vert gr)
+        , post <- Set.toList (AM.postSet vert gr)
+        ]

src/App/Fossa/Analyze/GraphMangler.hs

@@ -14,12 +14,13 @@ import Data.Set qualified as Set
 import App.Fossa.Analyze.Graph qualified as G
 import App.Fossa.Analyze.GraphBuilder
 import DepTypes
-import Graphing (Graphing (..))
+import Graphing (Graphing)
+import Graphing qualified
 
 graphingToGraph :: Graphing Dependency -> G.Graph
 graphingToGraph graphing = run . evalGraphBuilder G.empty $ do
-  let depAmap = graphingAdjacent graphing
-      depDirect = Set.toList (graphingDirect graphing)
+  let depAmap = Graphing.toAdjacencyMap graphing
+      depDirect = Graphing.directList graphing
 
       nodes = dfs depDirect depAmap
 

src/App/Fossa/Analyze/Project.hs

@@ -3,7 +3,6 @@ module App.Fossa.Analyze.Project (
   mkResult,
 ) where
 
-import Data.Set qualified as Set
 import Data.Text (Text)
 import DepTypes
 import Graphing (Graphing)
@@ -22,7 +21,7 @@ mkResult project graphResults =
         -- their dependencies would be filtered out. The real fix to this is to
         -- have a separate designation for "reachable" vs "direct" on nodes in a
         -- Graphing, where direct deps are inherently reachable.
-        if Set.null (Graphing.graphingDirect graph)
+        if null (Graphing.directList graph)
           then graph
           else Graphing.pruneUnreachable graph
     , projectResultGraphBreadth = graphBreadth

src/Effect/Grapher.hs

@@ -9,7 +9,7 @@ module Effect.Grapher (
   Grapher (..),
   direct,
   edge,
-  addNode,
+  deep,
   evalGrapher,
   runGrapher,
 
@@ -48,16 +48,16 @@ import Prettyprinter (pretty)
 data Grapher ty (m :: Type -> Type) k where
   Direct :: ty -> Grapher ty m ()
   Edge :: ty -> ty -> Grapher ty m ()
-  Node :: ty -> Grapher ty m ()
+  Deep :: ty -> Grapher ty m ()
 
 direct :: Has (Grapher ty) sig m => ty -> m ()
-direct ty = send (Direct ty)
+direct = send . Direct
 
 edge :: Has (Grapher ty) sig m => ty -> ty -> m ()
 edge parent child = send (Edge parent child)
 
-addNode :: Has (Grapher ty) sig m => ty -> m ()
-addNode v = send (Node v)
+deep :: Has (Grapher ty) sig m => ty -> m ()
+deep = send . Deep
 
 evalGrapher :: (Ord ty, Algebra sig m) => GrapherC ty m a -> m (G.Graphing ty)
 evalGrapher = fmap fst . runGrapher
@@ -66,9 +66,9 @@ type GrapherC ty m = SimpleStateC (G.Graphing ty) (Grapher ty) m
 
 runGrapher :: (Ord ty, Algebra sig m) => GrapherC ty m a -> m (G.Graphing ty, a)
 runGrapher = interpretState G.empty $ \case
-  Direct ty -> modify (G.direct ty)
-  Edge parent child -> modify (G.edge parent child)
-  Node n -> modify (G.deep n)
+  Direct ty -> modify (G.direct ty <>)
+  Edge parent child -> modify (G.edge parent child <>)
+  Deep n -> modify (G.deep n <>)
 
 ----- Labeling