Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add fusion experiments

  • Loading branch information...
commit 3755c06b4aa7bf2e29900fdae3ca20197c93b969 1 parent a18ba90
Max Bolingbroke authored
Showing with 160 additions and 0 deletions.
  1. +71 −0 DeforestFree.hs
  2. +89 −0 StreamFusionReassoc.hs
71 DeforestFree.hs
View
@@ -0,0 +1,71 @@
+{-# LANGUAGE Rank2Types #-}
+
+import Control.Monad
+
+
+newtype CodensityPlus p a = CodensityPlus { runCodensityPlus :: forall b. (a -> p b -> p b) -> p b -> p b }
+
+liftCodensityPlus :: MonadPlus p => p a -> CodensityPlus p a
+liftCodensityPlus m = CodensityPlus (\fmsuc mfai -> m >>= (\x -> fmsuc x mfai))
+
+lowerCodensityPlus :: MonadPlus p => CodensityPlus p a -> p a
+lowerCodensityPlus m = runCodensityPlus m (\x mx -> return x `mplus` mx) mzero
+
+instance Functor (CodensityPlus p) where
+ fmap f m = CodensityPlus (\fmsuc mfai -> runCodensityPlus m (fmsuc . f) mfai)
+
+instance Monad (CodensityPlus p) where
+ return x = CodensityPlus (\fmsuc mfai -> fmsuc x mfai)
+ mx >>= fxmy = CodensityPlus (\fmsuc mfai -> runCodensityPlus mx (\x mfai -> runCodensityPlus (fxmy x) fmsuc mfai) mfai)
+
+instance MonadPlus (CodensityPlus p) where
+ mzero = CodensityPlus (\_fmsuc mfai -> mfai)
+ m1 `mplus` m2 = CodensityPlus (\fmsuc mfai -> runCodensityPlus m1 fmsuc (runCodensityPlus m2 fmsuc mfai))
+
+
+{-# NOINLINE interpret #-}
+interpret :: [a] -> CodensityPlus [] a
+interpret = liftCodensityPlus
+
+{-# NOINLINE reify #-}
+reify :: CodensityPlus [] a -> [a]
+reify = lowerCodensityPlus
+
+
+{-# RULES "reify/interpret" forall xs. interpret (reify xs) = xs #-}
+
+
+{-# INLINE mapL #-}
+mapL :: (a -> b) -> [a] -> [b]
+mapL f xs = reify (mapD f (interpret xs))
+
+{-# INLINE mapD #-}
+mapD :: Monad m => (a -> b) -> m a -> m b
+mapD f mx = do
+ x <- mx
+ return (f x)
+
+{-# INLINE concatMapL #-}
+concatMapL f xs = reify (concatMapD (interpret . f) (interpret xs))
+
+{-# INLINE concatMapD #-}
+concatMapD :: Monad m => (a -> m b) -> m a -> m b
+concatMapD = flip (>>=)
+
+{-# INLINE enumFromToL #-}
+enumFromToL :: Int -> Int -> [Int]
+enumFromToL x y = reify (enumFromToD x y)
+
+{-# INLINE enumFromToD #-}
+{-# SPECIALISE enumFromToD :: Int -> Int -> CodensityPlus p Int #-}
+enumFromToD :: MonadPlus m => Int -> Int -> m Int
+enumFromToD x y | x > y = mzero
+ | otherwise = return x `mplus` enumFromToD (x + 1) y
+
+
+main :: IO ()
+main = do
+ print (reify (interpret ([1..10] :: [Int])))
+ print (reify (interpret (enumFromToL 1 10 :: [Int])))
+ print (mapL (+1) (mapL (+2) (enumFromToL 2 10)) :: [Int])
+ print (concatMapL (\y -> return (y+4) `mplus` return (y+5)) (concatMapL (\x -> return (x+2) `mplus` return (x+3)) (enumFromToL 2 10)) :: [Int])
89 StreamFusionReassoc.hs
View
@@ -0,0 +1,89 @@
+{-# LANGUAGE ExistentialQuantification, BangPatterns, TypeOperators #-}
+import Prelude hiding (enumFromTo, concatMap, replicate)
+
+data Stream a = forall s. Stream !(s -> Step a s) -- a stepper function
+ !s -- an initial state
+
+-- | A stream step.
+--
+-- A step either ends a stream, skips a value, or yields a value
+--
+data Step a s = Yield a !s
+ | Skip !s
+ | Done
+
+
+-- | Construct an abstract stream from a list.
+stream :: [a] -> Stream a
+stream xs0 = Stream next xs0
+ where
+ {-# INLINE next #-}
+ next [] = Done
+ next (x:xs) = Yield x xs
+{-# INLINE [0] stream #-}
+
+-- | Flatten a stream back into a list.
+unstream :: Stream a -> [a]
+unstream (Stream next s0) = unfold_unstream s0
+ where
+ unfold_unstream !s = case next s of
+ Done -> []
+ Skip s' -> unfold_unstream s'
+ Yield x s' -> x : unfold_unstream s'
+{-# INLINE [0] unstream #-}
+
+--
+-- /The/ stream fusion rule
+--
+
+{-# RULES
+"STREAM stream/unstream fusion" forall s.
+ stream (unstream s) = s
+ #-}
+
+
+{-# INLINE replicate #-}
+replicate n x = unstream (replicateS n x)
+
+{-# INLINE [0] replicateS #-}
+replicateS :: Int -> a -> Stream a
+replicateS n x = Stream next n
+ where
+ {-# INLINE next #-}
+ next !i | i <= 0 = Done
+ | otherwise = Yield x (i-1)
+
+{-# INLINE enumFromTo #-}
+enumFromTo x y = unstream (enumFromToS x y)
+
+{-# INLINE [0] enumFromToS #-}
+enumFromToS x y = Stream step x
+ where
+ {-# INLINE step #-}
+ step x | x <= y = Yield x (x + 1)
+ | otherwise = Done
+
+data a :!: b = !a :!: !b
+
+{-# INLINE concatMap #-}
+concatMap f xs = unstream (concatMapS (stream . f) (stream xs))
+
+{-# INLINE [0] concatMapS #-}
+concatMapS :: (a -> Stream b) -> Stream a -> Stream b
+concatMapS f (Stream next0 s0) = Stream next (s0 :!: Nothing)
+ where
+ {-# INLINE next #-}
+ next (s :!: Nothing) = case next0 s of
+ Done -> Done
+ Skip s' -> Skip (s' :!: Nothing)
+ Yield x s' -> Skip (s' :!: Just (f x))
+
+ next (s :!: Just (Stream g t)) = case g t of
+ Done -> Skip (s :!: Nothing)
+ Skip t' -> Skip (s :!: Just (Stream g t'))
+ Yield x t' -> Yield x (s :!: Just (Stream g t'))
+
+-- [1,1,2,2,3,3,4,4,5,5,2,2,3,3,4,4,5,5,3,3,4,4,5,5,4,4,5,5,5,5]
+main = do
+ print $ concatMap (\y -> replicate 2 y) (concatMap (\x -> enumFromTo x 5) (enumFromTo 1 (5 :: Int)))
+ --print $ concatMap (\x -> concatMap (\y -> replicate 2 y) (enumFromTo x 5)) (enumFromTo 1 (5 :: Int))
Please sign in to comment.
Something went wrong with that request. Please try again.