Rearrange some modules

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,

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 ["}"]

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
 

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

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

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
 

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)