From 0d40ac132b602ccb7e9b92d536573b2f5ce1b03f Mon Sep 17 00:00:00 2001
From: Jan Tojnar <jtojnar@gmail.com>
Date: Sat, 27 Nov 2021 01:17:15 +0100
Subject: [PATCH] build: Print dependency graph on failure

---
 hakyll.cabal               | 14 +++++++++++++
 lib/Hakyll/Core/Runtime.hs | 40 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+)

diff --git a/hakyll.cabal b/hakyll.cabal
index d3297c42..4f60a4ef 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -95,6 +95,10 @@ Source-Repository head
   Type:     git
   Location: git://github.com/jaspervdj/hakyll.git
 
+Flag dependencyVisualization
+  Description: Include tool for generating dependency graph
+  Default:     True
+
 Flag previewServer
   Description: Include the preview server
   Default:     True
@@ -210,6 +214,12 @@ Library
     vector               >= 0.11     && < 0.13,
     yaml                 >= 0.8.11   && < 0.12
 
+  If flag(dependencyVisualization)
+    Build-depends:
+      graphviz           >= 2999.20 && < 2999.21
+    Cpp-options:
+      -DDEPENDENCY_VISUALIZATION
+
   If flag(previewServer)
     Build-depends:
       wai             >= 3.2   && < 3.3,
@@ -294,6 +304,10 @@ Test-suite hakyll-tests
     unordered-containers >= 0.2      && < 0.3,
     yaml                 >= 0.8.11   && < 0.12
 
+  If flag(dependencyVisualization)
+    Cpp-options:
+      -DDEPENDENCY_VISUALIZATION
+
   If flag(previewServer)
     Cpp-options:
       -DPREVIEW_SERVER
diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs
index e674b7ef..5a54df93 100644
--- a/lib/Hakyll/Core/Runtime.hs
+++ b/lib/Hakyll/Core/Runtime.hs
@@ -1,4 +1,5 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
 module Hakyll.Core.Runtime
     ( run
     , RunMode(..)
@@ -22,6 +23,13 @@ import           Data.Traversable                (for)
 import           System.Exit                     (ExitCode (..))
 import           System.FilePath                 ((</>))
 
+#ifdef DEPENDENCY_VISUALIZATION
+import           Data.GraphViz
+import           Data.GraphViz.Printing          (printIt, toDot, unqtText)
+import qualified Data.Text.Lazy                  as LT
+import qualified Data.Text.Lazy.IO               as LT
+#endif
+
 
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler.Internal
@@ -76,6 +84,7 @@ run mode config logger rules = do
             , runtimeTodo         = M.empty
             , runtimeFacts        = oldFacts
             , runtimeDependencies = M.empty
+            , runtimeFullDependencies = M.empty
             }
 
     -- Build runtime read/state
@@ -125,6 +134,7 @@ data RuntimeState = RuntimeState
     , runtimeTodo         :: Map Identifier (Compiler SomeItem)
     , runtimeFacts        :: DependencyFacts
     , runtimeDependencies :: Map Identifier (Set (Identifier, Snapshot))
+    , runtimeFullDependencies :: Map Identifier (Set (Identifier, Snapshot))
     }
 
 
@@ -154,6 +164,12 @@ build mode = do
         RunModeNormal -> do
             Logger.header logger "Compiling"
             pickAndChase
+
+#ifdef DEPENDENCY_VISUALIZATION
+            fullDeps <- runtimeFullDependencies <$> getRuntimeState
+            liftIO . LT.putStrLn . printIt $ dependencyGraph fullDeps
+#endif
+
             Logger.header logger "Success"
             facts <- runtimeFacts <$> getRuntimeState
             store <- runtimeStore <$> ask
@@ -204,10 +220,33 @@ pickAndChase = do
             -- This clause happens when chasing *every item* in `todo` resulted in 
             -- idling because tasks are all waiting on something: a dependency cycle  
             deps <- runtimeDependencies <$> getRuntimeState
+#ifdef DEPENDENCY_VISUALIZATION
+            fullDeps <- runtimeFullDependencies <$> getRuntimeState
+            liftIO . LT.putStrLn . printIt $ dependencyGraph fullDeps
+#endif
             throwError $ "Hakyll.Core.Runtime.pickAndChase: Dependency cycle detected: " ++ 
                 intercalate ", " [show k ++ " depends on " ++ show (S.toList v) | (k, v) <- M.toList deps]
         pickAndChase
 
+--------------------------------------------------------------------------------
+#ifdef DEPENDENCY_VISUALIZATION
+instance PrintDot Identifier where
+    unqtDot = unqtText . LT.pack . show
+    toDot = toDot . LT.pack . show
+
+-- | Produces a GraphViz representation of the runtimeDependencies graph.
+dependencyGraph :: Map Identifier (Set (Identifier, Snapshot)) -> DotGraph Identifier
+dependencyGraph fullDeps = graphElemsToDot graphParams (map labelNodes nodes) edges
+    where
+        nodes = S.toList (M.keysSet fullDeps `S.union` foldMap (S.map fst) fullDeps)
+        edges = S.toList (M.foldMapWithKey (\ident -> S.map (\(dep, snap) -> (ident, dep, snap))) fullDeps)
+        graphParams = defaultParams
+            { clusterBy = \(n, nl) -> C (toFilePath n) (N (n, nl))
+            , clusterID = Str . LT.pack
+            , fmtEdge = \(_, _, el) -> if null el then [] else [textLabel (LT.pack el)]
+            }
+        labelNodes ident = (ident, show ident)
+#endif
 
 --------------------------------------------------------------------------------
 -- | Tracks whether a set of tasks has progressed overall (at least one task progressed)
@@ -330,6 +369,7 @@ chase id' = do
                     (runtimeTodo s)
                  -- We track dependencies only to inform users when an infinite loop is detected
                 , runtimeDependencies = M.insertWith S.union id' (S.fromList deps) (runtimeDependencies s)
+                , runtimeFullDependencies = M.insertWith S.union id' (S.fromList reqs) (runtimeFullDependencies s)
                 }
 
             -- Progress has been made if at least one of the