From 5e85b5d578a4589a2ea63f030e3c29bf26a1b0d1 Mon Sep 17 00:00:00 2001
From: Ryan Trinkle <ryan@trinkle.org>
Date: Wed, 21 Jun 2023 15:09:32 -0400
Subject: [PATCH] Rearrange some modules

---
 reflex.cabal                    |  1 +
 src/Reflex/Spider/Debugger.hs   | 50 +++++++++++++++++++++++++++++++++
 src/Reflex/Spider/Internal.hs   |  5 ----
 src/Reflex/Spider/Ref.hs        | 20 ++++++-------
 src/Reflex/Spider/Ref/Debug.hs  |  2 +-
 src/Reflex/Spider/Ref/Normal.hs |  2 +-
 src/Reflex/Spider/Ref/Types.hs  | 12 ++++++++
 7 files changed, 75 insertions(+), 17 deletions(-)
 create mode 100644 src/Reflex/Spider/Debugger.hs
 create mode 100644 src/Reflex/Spider/Ref/Types.hs

diff --git a/reflex.cabal b/reflex.cabal
index ab8e2cc5..5e745176 100644
--- a/reflex.cabal
+++ b/reflex.cabal
@@ -113,6 +113,7 @@ library
     Reflex.Spider.Ref,
     Reflex.Spider.Ref.Debug,
     Reflex.Spider.Ref.Normal,
+    Reflex.Spider.Ref.Types,
     Reflex.Spider.NodeInfo,
     Reflex.Spider.NodeInfo.Debug,
     Reflex.Spider.NodeInfo.Normal,
diff --git a/src/Reflex/Spider/Debugger.hs b/src/Reflex/Spider/Debugger.hs
new file mode 100644
index 00000000..5dbd5a4e
--- /dev/null
+++ b/src/Reflex/Spider/Debugger.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Reflex.Spider.Debugger where
+
+import Prelude hiding (filter)
+
+import Control.Monad.RWS
+import Data.Foldable
+import Data.List (intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Trie (Trie (..))
+import qualified Data.Trie as Trie
+import Data.Sequence ((<|))
+import qualified Data.Sequence as Seq
+import Data.Witherable
+
+
+indent :: MonadWriter [String] m => m a -> m a
+indent = censor (fmap ("  " <>))
+
+trieToDot :: Trie String (Map Int (Set Int)) -> RWS () [String] Int ()
+trieToDot (Trie prefix leaves children) = do
+  myId <- get
+  put $! succ myId
+  tell ["subgraph cluster_" <> show myId <> " {"]
+  indent $ do
+    tell ["label = " <> show (intercalate "\n" $ reverse $ toList prefix) <> ";"]
+    forM_ (maybe [] Map.toList leaves) $ \(nodeId, _) -> do
+      tell ["n" <> show nodeId <> " [label=" <> show ("#" <> show nodeId) <> "];"]
+    forM_ (Map.toList children) $ \(discriminatorStackFrame, Trie childStackFrames childLeaves childChildren) -> do
+      trieToDot $ Trie (discriminatorStackFrame <| childStackFrames) childLeaves childChildren
+  tell ["}"]
+
+showDot :: [([String], (Int, Set Int))] -> String
+showDot nodes = unlines $ snd $ execRWS graph () 1
+  where
+    includedNodes = Set.fromList $ fmap (\(_, (nodeId, _)) -> nodeId) nodes
+    t = Trie.fromList $ (\(stack, (nodeId, parents)) -> (Seq.fromList stack, Map.singleton nodeId $ Set.intersection includedNodes parents)) <$> filter (\(_, (nodeId, _)) -> nodeId `Set.member` includedNodes) nodes
+    edges = fmap (Set.intersection includedNodes) $ Map.fromList $ fmap snd nodes
+    graph = do
+      tell ["digraph {"]
+      indent $ do
+        tell ["labelloc=b;"]
+        trieToDot t
+        forM_ (Map.toList edges) $ \(nodeId, parents) -> do
+          when (nodeId `Set.member` includedNodes) $ do
+            tell ["{" <> intercalate ";" ((\parentId -> "n" <> show parentId) <$> Set.toList (Set.intersection includedNodes parents)) <> "} -> n" <> show nodeId <> ";"]
+      tell ["}"]
diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs
index e341cd1e..c81668ec 100644
--- a/src/Reflex/Spider/Internal.hs
+++ b/src/Reflex/Spider/Internal.hs
@@ -78,11 +78,6 @@ import System.Mem.Weak
 import Unsafe.Coerce
 
 import Reflex.Spider.Ref
-#ifdef DEBUG_TRACE_REFS
-import Reflex.Spider.Ref.Debug
-#else
-import Reflex.Spider.Ref.Normal
-#endif
 
 import Reflex.Spider.Debugger
 
diff --git a/src/Reflex/Spider/Ref.hs b/src/Reflex/Spider/Ref.hs
index 64b2ee02..740b50bb 100644
--- a/src/Reflex/Spider/Ref.hs
+++ b/src/Reflex/Spider/Ref.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE TypeFamilies #-}
-module Reflex.Spider.Ref where
+{-# LANGUAGE CPP #-}
+module Reflex.Spider.Ref
+  ( module X
+  ) where
 
-class RefCtx ctx where
-  data RefName ctx :: *
-  traceRef :: RefName ctx -> RefAction -> IO ()
+import Reflex.Spider.Ref.Types as X
 
-data RefAction
-   = RefAction_Write
-   | RefAction_Modify
-   | RefAction_Modify'
-   deriving (Show)
+#ifdef DEBUG_TRACE_REFS
+import Reflex.Spider.Ref.Debug as X
+#else
+import Reflex.Spider.Ref.Normal as X
+#endif
diff --git a/src/Reflex/Spider/Ref/Debug.hs b/src/Reflex/Spider/Ref/Debug.hs
index 76a8ae2c..622c3308 100644
--- a/src/Reflex/Spider/Ref/Debug.hs
+++ b/src/Reflex/Spider/Ref/Debug.hs
@@ -2,7 +2,7 @@ module Reflex.Spider.Ref.Debug where
 
 import Data.IORef
 
-import Reflex.Spider.Ref
+import Reflex.Spider.Ref.Types
 
 data Ref ctx a = Ref
   { _ref_name :: RefName ctx
diff --git a/src/Reflex/Spider/Ref/Normal.hs b/src/Reflex/Spider/Ref/Normal.hs
index 58a2c66f..85777c98 100644
--- a/src/Reflex/Spider/Ref/Normal.hs
+++ b/src/Reflex/Spider/Ref/Normal.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- We need the redundant constraints in this module to stay consistent with the debug version
 module Reflex.Spider.Ref.Normal where
 
-import Reflex.Spider.Ref
+import Reflex.Spider.Ref.Types
 
 import Data.IORef
 
diff --git a/src/Reflex/Spider/Ref/Types.hs b/src/Reflex/Spider/Ref/Types.hs
new file mode 100644
index 00000000..f14851c2
--- /dev/null
+++ b/src/Reflex/Spider/Ref/Types.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TypeFamilies #-}
+module Reflex.Spider.Ref.Types where
+
+class RefCtx ctx where
+  data RefName ctx :: *
+  traceRef :: RefName ctx -> RefAction -> IO ()
+
+data RefAction
+   = RefAction_Write
+   | RefAction_Modify
+   | RefAction_Modify'
+   deriving (Show)