[commit: ghc] supercompiler: Checkpoint pretty-printing (f099c36)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/f099c361db9ff8f2fdd86f92308130765428621d

>---------------------------------------------------------------

commit f099c361db9ff8f2fdd86f92308130765428621d
Author: Max Bolingbroke <[email protected]>
Date:   Thu Sep 8 11:22:32 2011 +0100

    Checkpoint pretty-printing

>---------------------------------------------------------------

 .../supercompile/Supercompile/Drive/Process.hs     |   39 ++++++++++++++------
 1 files changed, 28 insertions(+), 11 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index a780c3c..1c51896 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -505,7 +505,11 @@ instance Traversable Capturable where
     traverse _ Captured        = pure Captured
     traverse f (NotCaptured x) = NotCaptured <$> f x
 
-data PTree a = Tieback Var | Split Bool [a] [PTree a]
+data PTree a = Tieback Var              -- ^ Didn't promise or drive extra stuff: just tied back
+             | Split Bool [a] [PTree a] -- ^ Made a promise, fulfiling it like so (with 1 or 2 fulfilments..)
+                                        --   and where the children are these
+             | BoundCapturedFloats FreeVars [PTree a]
+                                        -- ^ Produced these children within the context of these BVs
 
 instance Functor PTree where fmap = Traversable.fmapDefault
 instance Foldable PTree where foldMap = Traversable.foldMapDefault
@@ -513,6 +517,7 @@ instance Foldable PTree where foldMap = Traversable.foldMapDefault
 instance Traversable PTree where
     traverse _ (Tieback n)  = pure (Tieback n)
     traverse f (Split rb x ts) = Split rb <$> traverse f x <*> traverse (traverse f) ts
+    traverse f (BoundCapturedFloats bvs ts) = BoundCapturedFloats bvs <$> traverse (traverse f) ts
 
 -- Fulfilments at each level and the free variables of bindCapturedFloats that caused them to pushed.
 -- We guarantee that promises for each these are already present in the promises field.
@@ -597,26 +602,38 @@ catchScpM f_try f_abort = ScpM $ \e s k -> unScpM (f_try (\c -> ScpM $ \e' s' _k
                                    -- from inside (deeper in the tree) to the outside (closer to top level).
                                    go :: (VarSet, [FulfilmentTree]) -> PTreeContextItem -> (VarSet, [FulfilmentTree])
                                    go (partial_not_completed, fs_floating) (Promise p) = (partial_not_completed `extendVarSet` fun p, [Split True [NotCaptured (p { meaning = Nothing }, RolledBack)] fs_floating])
-                                   go (partial_not_completed, fs_floating) (BindCapturedFloats extra_statics fs_pre_bind) = (partial_not_completed, unComp fs_ok)
-                                      where (_fs_discard, fs_ok) = partitionFulfilments fulfilmentRefersTo mkVarSet (not_completed `unionVarSet` extra_statics) (Comp (fs_pre_bind ++ fs_floating))
+                                   go (partial_not_completed, fs_floating) (BindCapturedFloats extra_statics fs_pre_bind) = (partial_not_completed, fs_pre_bind ++ [BoundCapturedFloats extra_statics (unComp fs_ok)])
+                                      where (_fs_discard, fs_ok) = partitionFulfilments fulfilmentRefersTo mkVarSet (not_completed `unionVarSet` extra_statics) (Comp fs_floating)
 
                                    (not_completed, fs_floating) = foldl' go (emptyVarSet, []) fss_candidates
                                in s' { pTreeHole = fs_floating ++ pTreeHole s })
                          k)) e s k
 
-{-
-pprScpM :: ScpBM String
-pprScpM = ScpM $ \e s k -> k (ppr (unwind (pTreeContext e) (pTreeHole s)))
+addStats :: SCStats -> ScpM f f ()
+addStats scstats = ScpM $ \_e s k -> k () (let scstats' = stats s `mappend` scstats in scstats' `seqSCStats` s { stats = scstats' })
+
+
+type PrettyTree = PTree (Var, SDoc, Maybe SDoc)
+
+pprScpM :: ScpBM SDoc
+pprScpM = ScpM $ \e s k -> k (pprTrees (unwindContext (pTreeContext e) (map unwindTree (pTreeHole s)))) s
   where
+    unwindTree :: FulfilmentTree -> PrettyTree
+    unwindTree = fmap (\mb_f -> case mb_f of Captured      -> (??, ??, Nothing)
+                                             NotCaptured f -> unwindFulfilment f)
     
+    unwindFulfilment (p, mb_e') = (fun p, ppr (meaning p), case mb_e' of RolledBack -> Nothing
+                                                                         Fulfilled e' -> Just (ppr e'))
 
-    ppr ctxt fs
+    unwindContext :: PTreeContext -> [PrettyTree] -> [PrettyTree]
+    unwindContext = flip $ foldl (flip unwindContextItem)
 
-type PrettyTree = 
--}
+    unwindContextItem :: PTreeContextItem -> [PrettyTree] -> [PrettyTree]
+    unwindContextItem (Promise p)                  ts = [Split True [(fun p, ppr (meaning p), Nothing)] ts]
+    unwindContextItem (BindCapturedFloats fvs ts') ts = map unwindTree ts' ++ [BoundCapturedFloats fvs ts]
 
-addStats :: SCStats -> ScpM f f ()
-addStats scstats = ScpM $ \_e s k -> k () (let scstats' = stats s `mappend` scstats in scstats' `seqSCStats` s { stats = scstats' })
+    pprTrees :: [PrettyTree] -> SDoc
+    pprTrees = undefined
 
 
 type RollbackScpM = Generaliser -> ScpBM (Deeds, Out FVedTerm)