diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmarks.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} + +-- The simplest/silliest of all benchmarks! + +import Criterion.Main +import Control.Eff as E +import Control.Eff.Exception as E.Er +import Control.Eff.NdetEff as E.ND +import Control.Eff.State.Strict as E.S +import Control.Monad + +-- For comparison +-- We use a strict State monad, because of large space leaks with the +-- lazy monad (one test even overflows the stack) +import Control.Monad.State.Strict as S +import Control.Monad.Error as Er +-- import Control.Monad.Reader as Rd +import Control.Monad.Cont as Ct +import Control.Applicative + +main :: IO () +main = defaultMain [ + bgroup "state" [ bgroup "10k" [ bench "mtl" $ whnf benchCnt_State 10000 + , bench "eff" $ whnf benchCnt_Eff 10000 + ] + ] + , bgroup "error" [ bgroup "50k" [ bench "mtl" $ whnf benchMul_Error 50000 + , bench "eff" $ whnf benchMul_Eff 50000 + ] + ] + , bgroup "st-error" [ bgroup "err : st" [ bench "mtl" $ whnf mainMax_MTL 10000 + , bench "eff" $ whnf mainMax_Eff 10000 + ] + , bgroup "st : err" [ bench "mtl" $ whnf mainMax1_MTL 10000 + , bench "eff" $ whnf mainMax1_Eff 10000 + ] + ] + , bgroup "pyth" [ bgroup "ndet" [ bench "mtl" $ whnf mainN_MTL 20 + , bench "eff" $ whnf mainN_Eff 20 + ] + , bgroup "ndet : st" [ bench "mtl" $ nf mainNS_MTL 15 + , bench "eff" $ nf mainNS_Eff 15 + ] + ] + ] + +-- ------------------------------------------------------------------------ +-- Single State, with very little non-effectful computation +-- This is a micro-benchmark, and hence not particularly realistic. +-- Because of its simplicity, GHC may do a lot of inlining. +-- See a more realistic max benchmark below, which does a fair amount +-- of computation other than accessing the state. + +-- Count-down +benchCnt_State :: Int -> ((),Int) +benchCnt_State n = S.runState m n + where + m = do + x <- S.get + if x > 0 then S.put (x-1) >> m else return () + +benchCnt_Eff :: Int -> ((),Int) +benchCnt_Eff n = run $ E.S.runState m n + where + m = do + x <- E.S.get + if x > 0 then E.S.put (x-1::Int) >> m else return () + +-- ------------------------------------------------------------------------ +-- Single Error + +-- Multiply a list of numbers, throwing an exception when encountering 0 +-- This is again a mcro-benchmark + +-- make a list of n ones followed by 0 +be_make_list :: Int -> [Int] +be_make_list n = replicate n 1 ++ [0] + +instance Error Int where + +benchMul_Error :: Int -> Int +benchMul_Error n = either id id m + where + m = foldM f 1 (be_make_list n) + f acc 0 = Er.throwError 0 + f acc x = return $! acc * x + +benchMul_Eff :: Int -> Int +benchMul_Eff n = either id id . run . runExc $ m + where + m = foldM f 1 (be_make_list n) + f acc 0 = E.Er.throwExc (0::Int) + f acc x = return $! acc * x + +-- ------------------------------------------------------------------------ +-- State and Error and non-effectful computation + +benchMax_MTL :: (MonadState Int m, MonadError Int m) => Int -> m Int +benchMax_MTL n = foldM f 1 [n, n-1 .. 0] + where + f acc 0 = Er.throwError 0 + f acc x | x `mod` 5 == 0 = do + s <- S.get + S.put $! (s+1) + return $! max acc x + f acc x = return $! max acc x + +mainMax_MTL n = S.runState (Er.runErrorT (benchMax_MTL n)) 0 + +-- Different order of layers +mainMax1_MTL n = (S.runStateT (benchMax_MTL n) 0 :: Either Int (Int,Int)) + +benchMax_Eff :: (Member (Exc Int) r, Member (E.S.State Int) r) => + Int -> Eff r Int +benchMax_Eff n = foldM f 1 [n, n-1 .. 0] + where + f acc 0 = E.Er.throwExc (0::Int) + f acc x | x `mod` 5 == 0 = do + s <- E.S.get + E.S.put $! (s+1::Int) + return $! max acc x + f acc x = return $! max acc x + + +mainMax_Eff n = ((run $ E.S.runState (E.Er.runExc (benchMax_Eff n)) 0) :: + (Either Int Int,Int)) + +mainMax1_Eff n = ((run $ E.Er.runExc (E.S.runState (benchMax_Eff n) 0)) :: + Either Int (Int,Int)) + +-- ------------------------------------------------------------------------ +-- Non-determinism benchmark: Pythagorian triples + +-- First benchmark, with non-determinism only + +-- Stream from k to n +iota k n = if k > n then mzero else return k `mplus` iota (k+1) n + +pyth1 :: MonadPlus m => Int -> m (Int, Int, Int) +pyth1 upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + if x*x + y*y == z*z then return (x,y,z) else mzero + +pyth20 = + [(3,4,5),(4,3,5),(5,12,13),(6,8,10),(8,6,10),(8,15,17),(9,12,15),(12,5,13), + (12,9,15),(12,16,20),(15,8,17),(16,12,20)] + +pythr_MTL = pyth20 == ((runCont (pyth1 20) (\x -> [x])) :: [(Int,Int,Int)]) + +pythr_EFF = pyth20 == ((run . E.ND.makeChoiceA $ pyth1 20) :: [(Int,Int,Int)]) + + +-- There is no instance of MonadPlus for ContT +-- we have to make our own + +instance Monad m => MonadPlus (ContT [r] m) where + mzero = ContT $ \k -> return [] + mplus (ContT m1) (ContT m2) = ContT $ \k -> + liftM2 (++) (m1 k) (m2 k) + +instance Monad m => Alternative (ContT [r] m) where + empty = mzero + (<|>) = mplus + +mainN_MTL n = ((runCont (pyth1 n) (\x -> [x])) :: [(Int,Int,Int)]) + +mainN_Eff n = ((run . E.ND.makeChoiceA $ pyth1 n) :: [(Int,Int,Int)]) + +-- Adding state: counting the number of choices + +pyth2 :: Int -> ContT [r] (S.State Int) (Int, Int, Int) +pyth2 upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + cnt <- S.get + S.put $! (cnt + 1) + if x*x + y*y == z*z then return (x,y,z) else mzero + +pythrNS_MTL :: ([(Int,Int,Int)],Int) +pythrNS_MTL = S.runState (runContT (pyth2 20) (\x -> return [x])) 0 + +pyth2E :: (Member (E.S.State Int) r, Member NdetEff r) => + Int -> Eff r (Int, Int, Int) +pyth2E upbound = do + x <- iota 1 upbound + y <- iota 1 upbound + z <- iota 1 upbound + cnt <- E.S.get + E.S.put $! (cnt + 1::Int) + if x*x + y*y == z*z then return (x,y,z) else mzero + + +pyth2Er :: ([(Int,Int,Int)],Int) +pyth2Er = run . (`E.S.runState` 0) . E.ND.makeChoiceA $ pyth2E 20 + +mainNS_MTL n = + let (l,cnt) = S.runState (runContT (pyth2 n) (\x -> return [x])) 0 + in ((l::[(Int,Int,Int)]), (cnt::Int)) + +mainNS_Eff n = + let (l,cnt) = run . (`E.S.runState` 0) . E.ND.makeChoiceA $ pyth2E n + in ((l::[(Int,Int,Int)]), (cnt::Int)) diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.1.0.0 +version: 2.2.1.0 -- A short (one-line) description of the package. synopsis: An Alternative to Monad Transformers @@ -175,6 +175,19 @@ , test-framework-th >= 0.2 , extensible-effects , directory >= 1.2 && < 1.4 + + default-language: Haskell2010 + +benchmark extensible-effects-benchmarks + type: exitcode-stdio-1.0 + main-is: Benchmarks.hs + hs-source-dirs: benchmark/ + ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields + build-depends: + base + , criterion + , extensible-effects + , mtl default-language: Haskell2010 diff --git a/src/Control/Eff.hs b/src/Control/Eff.hs --- a/src/Control/Eff.hs +++ b/src/Control/Eff.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Werror #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} @@ -28,6 +28,8 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif +import qualified Control.Arrow as A +import qualified Control.Category as C import safe Data.OpenUnion import safe Data.FTCQueue import GHC.Exts (inline) @@ -36,29 +38,75 @@ -- denoted by r type Arr r a b = a -> Eff r b --- | An effectful function from 'a' to 'b' that is a composition --- of several effectful functions. The paremeter r describes the overall --- effect. --- The composition members are accumulated in a type-aligned queue -type Arrs r a b = FTCQueue (Eff r) a b +-- | An effectful function from 'a' to 'b' that is a composition of one or more +-- effectful functions. The paremeter r describes the overall effect. +-- +-- The composition members are accumulated in a type-aligned queue. +-- Using a newtype here enables us to define `Category' and `Arrow' instances. +newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b) -{-# INLINE single #-} -single :: Arr r a b -> Arrs r a b -single = tsingleton +-- | 'Arrs' can be composed and have a natural identity. +instance C.Category (Arrs r) where + id = ident + f . g = comp g f --- FIXME: convert to 'Arrs' +-- | As the name suggests, 'Arrs' also has an 'Arrow' instance. +instance A.Arrow (Arrs r) where + arr = arr + first = singleK . first . (^$) + first :: Arr r a b -> Arr r (a, c) (b, c) first x = \(a,c) -> (, c) `fmap` x a +-- | convert single effectful arrow into composable type. i.e., convert 'Arr' to +-- 'Arrs' +{-# INLINE singleK #-} +singleK :: Arr r a b -> Arrs r a b +singleK = Arrs . tsingleton + +-- | Application to the `generalized effectful function' Arrs r b w, i.e., +-- convert 'Arrs' to 'Arr' +{-# INLINABLE qApp #-} +qApp :: forall r b w. Arrs r b w -> Arr r b w +qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons + where + cons :: forall x. Arr r b x -> FTCQueue (Eff r) x w -> Eff r w + cons = \k t -> case k x of + Val y -> qApp (Arrs t) y + E u (Arrs q0) -> E u (Arrs (q0 >< t)) +{- +-- A bit more understandable version +qApp :: Arrs r b w -> b -> Eff r w +qApp q x = case tviewl q of + TOne k -> k x + k :| t -> bind' (k x) t + where + bind' :: Eff r a -> Arrs r a b -> Eff r b + bind' (Pure y) k = qApp k y + bind' (Impure u q) k = Impure u (q >< k) +-} + +-- | Syntactic sugar for 'qApp' +{-# INLINABLE (^$) #-} +(^$) :: forall r b w. Arrs r b w -> Arr r b w +q ^$ x = q `qApp` x + +-- | Lift a function to an arrow arr :: (a -> b) -> Arrs r a b -arr f = single (Val . f) +arr f = singleK (Val . f) +-- | The identity arrow ident :: Arrs r a a ident = arr id +-- | Arrow composition comp :: Arrs r a b -> Arrs r b c -> Arrs r a c -comp = (><) +comp (Arrs f) (Arrs g) = Arrs (f >< g) +-- | Common pattern: append 'Arr' to 'Arrs' +(^|>) :: Arrs r a b -> Arr r b c -> Arrs r a c +(Arrs f) ^|> g = Arrs (f |> g) + -- | The Eff monad (not a transformer!). It is a fairly standard coroutine monad -- where the type @r@ is the type of effects that can be handled, and the -- missing type @a@ (from the type application) is the type of value that is @@ -75,69 +123,50 @@ data Eff r a = Val a | forall b. E (Union r b) (Arrs r b a) --- | Application to the `generalized effectful function' Arrs r b w -{-# INLINABLE qApp #-} -qApp :: Arrs r b w -> b -> Eff r w -qApp q x = - case inline tviewl q of - TOne k -> k x - k :| t -> case k x of - Val y -> qApp t y - E u q0 -> E u (q0 >< t) - -{- --- A bit more understandable version -qApp :: Arrs r b w -> b -> Eff r w -qApp q x = case tviewl q of - TOne k -> k x - k :| t -> bind' (k x) t - where - bind' :: Eff r a -> Arrs r a b -> Eff r b - bind' (Pure y) k = qApp k y - bind' (Impure u q) k = Impure u (q >< k) --} - -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComp #-} qComp :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arr r' a c -- qComp g h = (h . (g `qApp`)) -qComp g h = \a -> h $ qApp g a +qComp g h = \a -> h $ (g ^$ a) +-- | Compose effectful arrows (and possibly change the effect!) +{-# INLINE qComps #-} +qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c +qComps g h = singleK $ qComp g h + -- | Eff is still a monad and a functor (and Applicative) -- (despite the lack of the Functor constraint) instance Functor (Eff r) where {-# INLINE fmap #-} fmap f (Val x) = Val (f x) - fmap f (E u q) = E u (q |> (Val . f)) -- does no mapping yet! + fmap f (E u q) = E u (q ^|> (Val . f)) -- does no mapping yet! instance Applicative (Eff r) where {-# INLINE pure #-} pure = Val - Val f <*> Val x = Val $ f x - Val f <*> E u q = E u (q |> (Val . f)) - E u q <*> Val x = E u (q |> (Val . ($ x))) - E u q <*> m = E u (q |> (`fmap` m)) + Val f <*> e = f `fmap` e + E u q <*> e = E u (q ^|> (`fmap` e)) instance Monad (Eff r) where {-# INLINE return #-} {-# INLINE [2] (>>=) #-} return = pure Val x >>= k = k x - E u q >>= k = E u (q |> k) -- just accumulates continuations + E u q >>= k = E u (q ^|> k) -- just accumulates continuations {- Val _ >> m = m - E u q >> m = E u (q |> const m) + E u q >> m = E u (q ^|> const m) -} -- | Send a request and wait for a reply (resulting in an effectful -- computation). {-# INLINE [2] send #-} send :: Member t r => t v -> Eff r v -send t = E (inj t) (tsingleton Val) +send t = E (inj t) (singleK Val) -- This seems to be a very beneficial rule! On micro-benchmarks, cuts -- the needed memory in half and speeds up almost twice. {-# RULES - "send/bind" [~3] forall t k. send t >>= k = E (inj t) (tsingleton k) + "send/bind" [~3] forall t k. send t >>= k = E (inj t) (singleK k) #-} @@ -164,7 +193,7 @@ loop (Val x) = ret x loop (E u q) = case decomp u of Right x -> h x k - Left u0 -> E u0 (tsingleton k) + Left u0 -> E u0 (singleK k) where k = qComp q loop -- | Parameterized handle_relay @@ -178,7 +207,7 @@ loop s0 (Val x) = ret s0 x loop s0 (E u q) = case decomp u of Right x -> h s0 x k - Left u0 -> E u0 (tsingleton (k s0)) + Left u0 -> E u0 (singleK (k s0)) where k s1 x = loop s1 $ qApp q x -- | Add something like Control.Exception.catches? It could be useful @@ -195,5 +224,5 @@ loop (Val x) = ret x loop (E u q) = case prj u of Just x -> h x k - _ -> E u (tsingleton k) + _ -> E u (singleK k) where k = qComp q loop diff --git a/src/Control/Eff/Cut.hs b/src/Control/Eff/Cut.hs --- a/src/Control/Eff/Cut.hs +++ b/src/Control/Eff/Cut.hs @@ -70,8 +70,8 @@ Left u0 -> check jq u0 q check jq u _ | Just (Choose []) <- prj u = next jq -- (C1) - check jq u q | Just (Choose [x]) <- prj u = loop jq (qApp q x) -- (C3), optim - check jq u q | Just (Choose lst) <- prj u = next $ map (qApp q) lst ++ jq -- (C3) + check jq u q | Just (Choose [x]) <- prj u = loop jq (q ^$ x) -- (C3), optim + check jq u q | Just (Choose lst) <- prj u = next $ map (q ^$) lst ++ jq -- (C3) check jq u q = loop jq (E (weaken u) q) -- (C4) next :: Member Choose r diff --git a/src/Control/Eff/NdetEff.hs b/src/Control/Eff/NdetEff.hs --- a/src/Control/Eff/NdetEff.hs +++ b/src/Control/Eff/NdetEff.hs @@ -54,8 +54,8 @@ Right MZero -> case jq of [] -> return empty (h:t) -> loop t h - Right MPlus -> loop (qApp q False : jq) (qApp q True) - Left u0 -> E u0 (single (\x -> loop jq (qApp q x))) + Right MPlus -> loop (q ^$ False : jq) (q ^$ True) + Left u0 -> E u0 (singleK (\x -> loop jq (q ^$ x))) -- ------------------------------------------------------------------------ -- Soft-cut: non-deterministic if-then-else, aka Prolog's *-> @@ -71,7 +71,7 @@ msplit :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a)) msplit = loop [] where - -- single result + -- singleK result loop [] (Val x) = return (Just (x,mzero)) -- definite result and perhaps some others loop jq (Val x) = return (Just (x, msum jq)) @@ -82,8 +82,8 @@ [] -> return Nothing -- other choices remain, try them (j:jqT) -> loop jqT j - Just MPlus -> loop ((qApp q False):jq) (qApp q True) - _ -> E u (single k) where k = qComp q (loop jq) + Just MPlus -> loop ((q ^$ False):jq) (q ^$ True) + _ -> E u (qComps q (loop jq)) -- Other committed choice primitives can be implemented in terms of msplit -- The following implementations are directly from the LogicT paper diff --git a/src/Control/Eff/State/Lazy.hs b/src/Control/Eff/State/Lazy.hs --- a/src/Control/Eff/State/Lazy.hs +++ b/src/Control/Eff/State/Lazy.hs @@ -71,11 +71,11 @@ -> Eff r (w,s) -- ^ Effect containing final state and a return value runState (Val x) s = return (x,s) runState (E u0 q) s0 = case decomp u0 of - Right Get -> runState (qApp q s0) s0 - Right (Put s1) -> runState (qApp q ()) s1 + Right Get -> runState (q ^$ s0) s0 + Right (Put s1) -> runState (q ^$ ()) s1 Right (Delay m1) -> let ~(x,s1) = run $ runState m1 s0 - in runState (qApp q x) s1 - Left u -> E u (single (\x -> runState (qApp q x) s0)) + in runState (q ^$ x) s1 + Left u -> E u (singleK (\x -> runState (q ^$ x) s0)) -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -101,7 +101,7 @@ Right (Writer w v) -> k w v Left u -> case decomp u of Right (Reader f) -> k s (f s) - Left u1 -> E u1 (single (k s)) + Left u1 -> E u1 (singleK (k s)) where k x = qComp q (loop x) -- | Backwards state @@ -118,9 +118,9 @@ go :: s -> Eff '[State s] a -> (a,s) go s (Val x) = (x,s) go s0 (E u q) = case decomp u of - Right Get -> go s0 $ qApp q s0 - Right (Put s1) -> let ~(x,sp) = go sp $ qApp q () in (x,s1) - Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ qApp q x + Right Get -> go s0 $ (q ^$ s0) + Right (Put s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1) + Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ (q ^$ x) Left _ -> error "Impossible happened: Union []" -- | Another implementation, exploring Haskell's laziness to make putAttr diff --git a/src/Control/Eff/State/LazyState.hs b/src/Control/Eff/State/LazyState.hs --- a/src/Control/Eff/State/LazyState.hs +++ b/src/Control/Eff/State/LazyState.hs @@ -64,10 +64,10 @@ go :: s -> Eff '[LazyState s] a -> (a,s) go s (Val x) = (x,s) go s (E u q) = case decomp u of - Right LGet -> go s $ qApp q s - Right (LPut s1) -> let ~(x,sp) = go sp $ qApp q () in (x,s1) - Right (Delay m1) -> let ~(x,s1) = go s m1 in go s1 $ qApp q x - Left _ -> error "LazyState: the impossible happened" + Right LGet -> go s $ (q ^$ s) + Right (LPut s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1) + Right (Delay m1) -> let ~(x,s1) = go s m1 in go s1 $ (q ^$ x) + Left _ -> error "LazyState: the impossible happened: Union []" -- | Another implementation, exploring Haskell's laziness to make putAttr -- also technically inherited, to accumulate the sequence of diff --git a/src/Control/Eff/State/Strict.hs b/src/Control/Eff/State/Strict.hs --- a/src/Control/Eff/State/Strict.hs +++ b/src/Control/Eff/State/Strict.hs @@ -75,9 +75,9 @@ -> Eff r (w,s) -- ^ Effect containing final state and a return value runState (Val x) !s = return (x,s) runState (E u q) !s = case decomp u of - Right Get -> runState (qApp q s) s - Right (Put s1) -> runState (qApp q ()) s1 - Left u1 -> E u1 (single (\x -> runState (qApp q x) s)) + Right Get -> runState (q ^$ s) s + Right (Put s1) -> runState (q ^$ ()) s1 + Left u1 -> E u1 (singleK (\x -> runState (q ^$ x) s)) -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -102,9 +102,9 @@ loop :: s -> Eff r w -> Eff r w loop s (Val x) = put s >> return x loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of - Just Get -> loop s (qApp q s) - Just (Put s') -> loop s'(qApp q ()) - _ -> E u (single k) where k = qComp q (loop s) + Just Get -> loop s (q ^$ s) + Just (Put s') -> loop s'(q ^$ ()) + _ -> E u (qComps q (loop s)) -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the @@ -118,5 +118,5 @@ Right (Writer w v) -> k w v Left u1 -> case decomp u1 of Right (Reader f) -> k s0 (f s0) - Left u2 -> E u2 (single (k s0)) + Left u2 -> E u2 (singleK (k s0)) where k x = qComp q (loop x) diff --git a/src/Control/Eff/Trace.hs b/src/Control/Eff/Trace.hs --- a/src/Control/Eff/Trace.hs +++ b/src/Control/Eff/Trace.hs @@ -25,6 +25,6 @@ runTrace :: Eff '[Trace] w -> IO w runTrace (Val x) = return x runTrace (E u q) = case decomp u of - Right (Trace s) -> putStrLn s >> runTrace (qApp q ()) + Right (Trace s) -> putStrLn s >> runTrace (q ^$ ()) -- Nothing more can occur - Left _ -> error "runTrace: the impossible happened!" + Left _ -> error "runTrace: the impossible happened!: Union []" diff --git a/src/Data/FTCQueue.hs b/src/Data/FTCQueue.hs --- a/src/Data/FTCQueue.hs +++ b/src/Data/FTCQueue.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} -- | Fast type-aligned queue optimized to effectful functions @@ -11,7 +12,8 @@ tsingleton, (|>), -- snoc (><), -- append - ViewL(..), + ViewL, + viewlMap, tviewl ) where @@ -46,6 +48,16 @@ data ViewL m a b where TOne :: (a -> m b) -> ViewL m a b (:|) :: (a -> m x) -> (FTCQueue m x b) -> ViewL m a b + +-- | Process the Left-edge deconstruction +{-# INLINE viewlMap #-} +viewlMap :: ViewL m a b + -> ((a -> m b) -> c) + -> (forall x. (a -> m x) -> (FTCQueue m x b) -> c) + -> c +viewlMap view tone cons = case view of + TOne k -> tone k + k :| t -> cons k t {-# INLINABLE tviewl #-} tviewl :: FTCQueue m a b -> ViewL m a b