Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/9775401176aba21fa93e0688780ea8ac337333df >--------------------------------------------------------------- commit 9775401176aba21fa93e0688780ea8ac337333df Author: Max Bolingbroke <batterseapo...@hotmail.com> 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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
