Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/8088569e2b1651e9a66493ce2a7fd7cab8d1f07c >--------------------------------------------------------------- commit 8088569e2b1651e9a66493ce2a7fd7cab8d1f07c Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Oct 26 14:30:49 2011 +0100 Checkpoint building version of new process with function to delay folded in >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process2.hs | 69 ++++++++++---------- 1 files changed, 35 insertions(+), 34 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs index cc7c361..a69767f 100644 --- a/compiler/supercompile/Supercompile/Drive/Process2.hs +++ b/compiler/supercompile/Supercompile/Drive/Process2.hs @@ -51,7 +51,7 @@ import qualified Data.Set as S -import Control.Applicative (Applicative(..), (<$>)) +import Control.Applicative (Applicative(..), (<$>), liftA2) import Control.Monad (liftM2) import Data.Foldable (Foldable(..)) @@ -66,72 +66,73 @@ listToStream [] = error "listToStream" listToStream (x:xs) = x :< listToStream xs -data DelayStructure sh a where - Leaf :: a -> DelayStructure () a - Branch :: DelayStructure sh1 a -> DelayStructure sh2 a -> DelayStructure (sh1, sh2) a - -instance Show a => Show (DelayStructure sh a) where - show (Leaf x) = "Leaf (" ++ show x ++ ")" - show (Branch t1 t2) = "Branch (" ++ show t1 ++ ") (" ++ show t2 ++ ")" - -instance Functor (DelayStructure sh) where - fmap = Traversable.fmapDefault - -instance Foldable (DelayStructure sh) where - foldMap = Traversable.foldMapDefault - -instance Traversable (DelayStructure sh) where - traverse f (Leaf x) = Leaf <$> f x - traverse f (Branch t1 t2) = Branch <$> traverse f t1 <*> traverse f t2 +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 -- 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 a r = Done r - | forall sh. Delayed (DelayStructure sh (m (DelayM m a a))) (DelayStructure sh a -> DelayM m a r) +data DelayM m r = Done r + | forall sh. Delayed (DelayStructure sh m Q) (DelayStructure sh m A -> DelayM m r) -instance Functor (DelayM m a) where +instance Functor (DelayM m) where fmap f x = pure f <*> x -instance Applicative (DelayM m a) where +instance Applicative (DelayM m) where pure = return Done f <*> Done x = Done (f x) Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x) Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as) Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Branch qs1 qs2) (\(Branch as1 as2) -> k1 as1 <*> k2 as2) -instance Monad (DelayM m a) where +instance Monad (DelayM m) where return = Done Done x >>= fxmy = fxmy x Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy) -delay :: m (DelayM m a a) -> DelayM m a a -delay q = Delayed (Leaf q) (\(Leaf a) -> pure a) +delay :: m (DelayM m a) -> DelayM m a +delay q = Delayed (LeafQ q) (\(LeafA a) -> pure a) runDelayM :: (Applicative m, Monad m) - => (DelayM m a r -> DelayM m a r) -- ^ Chooses the evaluation strategy - -> DelayM m a r -> m r + => (DelayM m r -> DelayM m r) -- ^ Chooses the evaluation strategy + -> DelayM m r -> m r runDelayM choose_some = go where go = go' . choose_some go' (Done x) = pure x - go' (Delayed qs k) = sequenceA qs >>= \fs -> go (sequenceA fs >>= k) + go' (Delayed qs k) = mungeDS qs >>= \mx -> go (mx >>= k) + +mungeDS :: Applicative n + => DelayStructure sh n Q + -> n (DelayM n (DelayStructure sh m A)) +mungeDS (LeafQ mx) = fmap (fmap LeafA) 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 (Branch qs1 qs2) = liftA2 Branch (delayDS qs1) (delayDS qs2) -depthFirst :: DelayM m a r -> DelayM m a r +depthFirst :: DelayM m r -> DelayM m r depthFirst (Done x) = Done x depthFirst (Delayed qs k) = delayTail qs >>= k where - delayTail :: DelayStructure sh (m (DelayM m a a)) -> DelayM m a (DelayStructure sh a) - delayTail (Leaf q) = fmap Leaf (delay q) - delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (traverse delay qs2) + delayTail :: DelayStructure sh m Q -> DelayM m (DelayStructure sh m A) + delayTail (LeafQ q) = fmap LeafA (delay q) + delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (delayDS qs2) -breadthFirst :: DelayM m a r -> DelayM m a r +breadthFirst :: DelayM m r -> DelayM m r breadthFirst = id -type ScpM = DelayM (MemoT HistoryM) (Deeds, FVedTerm) +type ScpM = DelayM (MemoT HistoryM) traceRenderScpM :: (Outputable a, Monad m) => String -> a -> m () traceRenderScpM msg x = pprTraceSC msg (pPrint x) $ return () -- TODO: include depth, refine to ScpM monad only _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
