[commit: ghc] : Use a functor type parameter to DelayStructure rather than a GADT index (9775401)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/9775401176aba21fa93e0688780ea8ac337333df

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

commit 9775401176aba21fa93e0688780ea8ac337333df
Author: Max Bolingbroke <[email protected]>
Date:   Wed Oct 26 14:59:39 2011 +0100

    Use a functor type parameter to DelayStructure rather than a GADT index

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

 .../supercompile/Supercompile/Drive/Process2.hs    |   47 ++++++++++++-------
 compiler/supercompile/Supercompile/Utilities.hs    |    6 ++-
 2 files changed, 35 insertions(+), 18 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs
index a69767f..a023dd1 100644
--- a/compiler/supercompile/Supercompile/Drive/Process2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process2.hs
@@ -67,18 +67,19 @@ listToStream (x:xs) = x :< listToStream xs
 
 
 data LeafTy a
-data Q
-data A
 
-data DelayStructure sh m qa where
-    LeafQ :: m (DelayM m a) -> DelayStructure (LeafTy a) m Q
-    LeafA :: a              -> DelayStructure (LeafTy a) m A
-    Branch :: DelayStructure sh1 m qa -> DelayStructure sh2 m qa -> DelayStructure (sh1, sh2) m qa
+data DelayStructure sh f where
+    Leaf   :: f a -> DelayStructure (LeafTy a) f
+    Branch :: DelayStructure sh1 f -> DelayStructure sh2 f -> DelayStructure (sh1, sh2) f
+
+
+--newtype I a = I { unI :: a }
+newtype QM m a = QM { unQM :: m (DelayM m a) }
 
 -- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM,
 -- and make some of the consumers simpler. I actually want this generalisation, though.
 data DelayM m r = Done r
-                | forall sh. Delayed (DelayStructure sh m Q) (DelayStructure sh m A -> DelayM m r)
+                | forall sh. Delayed (DelayStructure sh (QM m)) (DelayStructure sh Identity -> DelayM m r)
 
 instance Functor (DelayM m) where
     fmap f x = pure f <*> x
@@ -96,7 +97,7 @@ instance Monad (DelayM m) where
     Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy)
 
 delay :: m (DelayM m a) -> DelayM m a
-delay q = Delayed (LeafQ q) (\(LeafA a) -> pure a)
+delay q = Delayed (Leaf (QM q)) (\(Leaf (I a)) -> pure a)
 
 runDelayM :: (Applicative m, Monad m)
           => (DelayM m r -> DelayM m r) -- ^ Chooses the evaluation strategy
@@ -108,24 +109,36 @@ runDelayM choose_some = go
     go' (Done x)       = pure x
     go' (Delayed qs k) = mungeDS qs >>= \mx -> go (mx >>= k)
 
+fmapNT :: Applicative m
+       => (forall a. f a -> m (g a))
+       -> DelayStructure sh f
+       -> m (DelayStructure sh g)
+fmapNT f (Leaf x)         = fmap Leaf (f x)
+fmapNT f (Branch qs1 qs2) = liftA2 Branch (fmapNT f qs1) (fmapNT f qs2)
+
 mungeDS :: Applicative n
-        => DelayStructure sh n Q
-        -> n (DelayM n (DelayStructure sh m A))
-mungeDS (LeafQ mx)       = fmap (fmap LeafA) mx
+        => DelayStructure sh (QM n)
+        -> n (DelayM n (DelayStructure sh Identity))
+mungeDS = unComp . fmapNT (Comp . fmap (fmap I) . unQM)
+{-
+mungeDS (Leaf (QM mx))   = fmap (fmap (Leaf . I)) mx
 mungeDS (Branch qs1 qs2) = liftA2 (liftA2 Branch) (mungeDS qs1) (mungeDS qs2)
+-}
 
-delayDS :: DelayStructure sh n Q
-        -> DelayM n (DelayStructure sh m A)
-delayDS (LeafQ mx)       = fmap LeafA (delay mx)
+delayDS :: DelayStructure sh (QM n)
+        -> DelayM n (DelayStructure sh Identity)
+delayDS = fmapNT (fmap I . delay . unQM)
+{-
+delayDS (Leaf (QM mx))   = fmap (Leaf . I) (delay mx)
 delayDS (Branch qs1 qs2) = liftA2 Branch (delayDS qs1) (delayDS qs2)
-
+-}
 
 depthFirst :: DelayM m r -> DelayM m r
 depthFirst (Done x)       = Done x
 depthFirst (Delayed qs k) = delayTail qs >>= k
   where
-    delayTail :: DelayStructure sh m Q -> DelayM m (DelayStructure sh m A)
-    delayTail (LeafQ q)        = fmap LeafA (delay q)
+    delayTail :: DelayStructure sh (QM m) -> DelayM m (DelayStructure sh Identity)
+    delayTail (Leaf (QM q))    = fmap (Leaf . I) (delay q)
     delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (delayDS qs2)
 
 breadthFirst :: DelayM m r -> DelayM m r
diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs
index c3c77e6..4dd57fb 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -25,7 +25,7 @@ import Outputable
 import State hiding (mapAccumLM)
 
 import Control.Arrow (first, second, (***), (&&&))
-import Control.Applicative (Applicative(..), (<$>))
+import Control.Applicative (Applicative(..), (<$>), liftA2)
 import Control.Exception (bracket)
 import Control.Monad hiding (join)
 
@@ -230,6 +230,10 @@ instance (Functor f, Outputable1 f, Outputable1 g, Outputable a) => Outputable (
 instance (Functor f, Functor g) => Functor (O f g) where
     fmap f (Comp x) = Comp (fmap (fmap f) x)
 
+instance (Applicative f, Applicative g) => Applicative (O f g) where
+    pure = Comp . pure . pure
+    mf <*> mx = Comp $ liftA2 (<*>) (unComp mf) (unComp mx)
+
 instance (Foldable f, Foldable g) => Foldable (O f g) where
     foldMap f = foldMap (foldMap f) . unComp