{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
#include "free-common.h"
module Control.Monad.Free.Church
( F(..)
, improve
, fromF
, iter
, iterM
, toF
, retract
, hoistF
, foldF
, MonadFree(..)
, liftF
, cutoff
) where
import Control.Applicative
import Control.Monad as Monad
import Control.Monad.Fix
import Control.Monad.Free hiding (retract, iter, iterM, cutoff)
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.Cont.Class
import Control.Monad.Trans.Class
import Control.Monad.State.Class
import Data.Foldable
import Data.Traversable
import Data.Functor.Bind
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Prelude hiding (foldr)
newtype F f a = F { F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF :: forall r. (a -> r) -> (f r -> r) -> r }
iter :: (f a -> a) -> F f a -> a
iter :: (f a -> a) -> F f a -> a
iter f a -> a
phi F f a
xs = F f a -> (a -> a) -> (f a -> a) -> a
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
xs a -> a
forall a. a -> a
id f a -> a
phi
iterM :: Monad m => (f (m a) -> m a) -> F f a -> m a
iterM :: (f (m a) -> m a) -> F f a -> m a
iterM f (m a) -> m a
phi F f a
xs = F f a -> (a -> m a) -> (f (m a) -> m a) -> m a
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
xs a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return f (m a) -> m a
phi
instance Functor (F f) where
fmap :: (a -> b) -> F f a -> F f b
fmap a -> b
f (F forall r. (a -> r) -> (f r -> r) -> r
g) = (forall r. (b -> r) -> (f r -> r) -> r) -> F f b
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\b -> r
kp -> (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
g (b -> r
kp (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Apply (F f) where
<.> :: F f (a -> b) -> F f a -> F f b
(<.>) = F f (a -> b) -> F f a -> F f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance Applicative (F f) where
pure :: a -> F f a
pure a
a = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp f r -> r
_ -> a -> r
kp a
a)
F forall r. ((a -> b) -> r) -> (f r -> r) -> r
f <*> :: F f (a -> b) -> F f a -> F f b
<*> F forall r. (a -> r) -> (f r -> r) -> r
g = (forall r. (b -> r) -> (f r -> r) -> r) -> F f b
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\b -> r
kp f r -> r
kf -> ((a -> b) -> r) -> (f r -> r) -> r
forall r. ((a -> b) -> r) -> (f r -> r) -> r
f (\a -> b
a -> (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
g (b -> r
kp (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
a) f r -> r
kf) f r -> r
kf)
instance Alternative f => Alternative (F f) where
empty :: F f a
empty = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
_ f r -> r
kf -> f r -> r
kf f r
forall (f :: * -> *) a. Alternative f => f a
empty)
F forall r. (a -> r) -> (f r -> r) -> r
f <|> :: F f a -> F f a -> F f a
<|> F forall r. (a -> r) -> (f r -> r) -> r
g = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp f r -> r
kf -> f r -> r
kf (r -> f r
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
f a -> r
kp f r -> r
kf) f r -> f r -> f r
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> r -> f r
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
g a -> r
kp f r -> r
kf)))
instance Bind (F f) where
>>- :: F f a -> (a -> F f b) -> F f b
(>>-) = F f a -> (a -> F f b) -> F f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
instance Monad (F f) where
return :: a -> F f a
return = a -> F f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
F forall r. (a -> r) -> (f r -> r) -> r
m >>= :: F f a -> (a -> F f b) -> F f b
>>= a -> F f b
f = (forall r. (b -> r) -> (f r -> r) -> r) -> F f b
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\b -> r
kp f r -> r
kf -> (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
m (\a
a -> F f b -> (b -> r) -> (f r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (a -> F f b
f a
a) b -> r
kp f r -> r
kf) f r -> r
kf)
instance MonadFix (F f) where
mfix :: (a -> F f a) -> F f a
mfix a -> F f a
f = F f a
a where
a :: F f a
a = a -> F f a
f (F f a -> a
forall (f :: * -> *) r. F f r -> r
impure F f a
a)
impure :: F f r -> r
impure (F forall r. (r -> r) -> (f r -> r) -> r
x) = (r -> r) -> (f r -> r) -> r
forall r. (r -> r) -> (f r -> r) -> r
x r -> r
forall a. a -> a
id ([Char] -> f r -> r
forall a. HasCallStack => [Char] -> a
error [Char]
"MonadFix (F f): wrap")
instance Foldable f => Foldable (F f) where
foldMap :: (a -> m) -> F f a -> m
foldMap a -> m
f F f a
xs = F f a -> (a -> m) -> (f m -> m) -> m
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
xs a -> m
f f m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
{-# INLINE foldMap #-}
foldr :: (a -> b -> b) -> b -> F f a -> b
foldr a -> b -> b
f b
r F f a
xs = F f a -> (a -> b -> b) -> (f (b -> b) -> b -> b) -> b -> b
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
xs a -> b -> b
f (((b -> b) -> (b -> b) -> b -> b)
-> (b -> b) -> f (b -> b) -> b -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) b -> b
forall a. a -> a
id) b
r
{-# INLINE foldr #-}
#if MIN_VERSION_base(4,6,0)
foldl' :: (b -> a -> b) -> b -> F f a -> b
foldl' b -> a -> b
f b
z F f a
xs = F f a -> (a -> b -> b) -> (f (b -> b) -> b -> b) -> b -> b
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
xs (\a
a !b
r -> b -> a -> b
f b
r a
a) ((b -> f (b -> b) -> b) -> f (b -> b) -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> f (b -> b) -> b) -> f (b -> b) -> b -> b)
-> (b -> f (b -> b) -> b) -> f (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ (b -> (b -> b) -> b) -> b -> f (b -> b) -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((b -> (b -> b) -> b) -> b -> f (b -> b) -> b)
-> (b -> (b -> b) -> b) -> b -> f (b -> b) -> b
forall a b. (a -> b) -> a -> b
$ \b
r b -> b
g -> b -> b
g b
r) b
z
{-# INLINE foldl' #-}
#endif
instance Traversable f => Traversable (F f) where
traverse :: (a -> f b) -> F f a -> f (F f b)
traverse a -> f b
f F f a
m = F f a
-> (a -> f (F f b)) -> (f (f (F f b)) -> f (F f b)) -> f (F f b)
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m ((b -> F f b) -> f b -> f (F f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> F f b
forall (m :: * -> *) a. Monad m => a -> m a
return (f b -> f (F f b)) -> (a -> f b) -> a -> f (F f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) ((f (F f b) -> F f b) -> f (f (F f b)) -> f (F f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (F f b) -> F f b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (f (F f b)) -> f (F f b))
-> (f (f (F f b)) -> f (f (F f b))) -> f (f (F f b)) -> f (F f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (f (F f b)) -> f (f (F f b))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA)
{-# INLINE traverse #-}
instance Foldable1 f => Foldable1 (F f) where
foldMap1 :: (a -> m) -> F f a -> m
foldMap1 a -> m
f F f a
m = F f a -> (a -> m) -> (f m -> m) -> m
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m a -> m
f f m -> m
forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1
instance Traversable1 f => Traversable1 (F f) where
traverse1 :: (a -> f b) -> F f a -> f (F f b)
traverse1 a -> f b
f F f a
m = F f a
-> (a -> f (F f b)) -> (f (f (F f b)) -> f (F f b)) -> f (F f b)
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m ((b -> F f b) -> f b -> f (F f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> F f b
forall (m :: * -> *) a. Monad m => a -> m a
return (f b -> f (F f b)) -> (a -> f b) -> a -> f (F f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) ((f (F f b) -> F f b) -> f (f (F f b)) -> f (F f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (F f b) -> F f b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (f (F f b)) -> f (F f b))
-> (f (f (F f b)) -> f (f (F f b))) -> f (f (F f b)) -> f (F f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (f (F f b)) -> f (f (F f b))
forall (t :: * -> *) (f :: * -> *) b.
(Traversable1 t, Apply f) =>
t (f b) -> f (t b)
sequence1)
instance MonadPlus f => MonadPlus (F f) where
mzero :: F f a
mzero = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
_ f r -> r
kf -> f r -> r
kf f r
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
F forall r. (a -> r) -> (f r -> r) -> r
f mplus :: F f a -> F f a -> F f a
`mplus` F forall r. (a -> r) -> (f r -> r) -> r
g = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp f r -> r
kf -> f r -> r
kf (r -> f r
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
f a -> r
kp f r -> r
kf) f r -> f r -> f r
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` r -> f r
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
g a -> r
kp f r -> r
kf)))
instance MonadTrans F where
lift :: m a -> F m a
lift m a
f = (forall r. (a -> r) -> (m r -> r) -> r) -> F m a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp m r -> r
kf -> m r -> r
kf ((a -> r) -> m a -> m r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> r
kp m a
f))
instance Functor f => MonadFree f (F f) where
wrap :: f (F f a) -> F f a
wrap f (F f a)
f = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp f r -> r
kf -> f r -> r
kf ((F f a -> r) -> f (F f a) -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (F forall r. (a -> r) -> (f r -> r) -> r
m) -> (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
m a -> r
kp f r -> r
kf) f (F f a)
f))
instance MonadState s m => MonadState s (F m) where
get :: F m s
get = m s -> F m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
put :: s -> F m ()
put = m () -> F m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> F m ()) -> (s -> m ()) -> s -> F m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
instance MonadReader e m => MonadReader e (F m) where
ask :: F m e
ask = m e -> F m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m e
forall r (m :: * -> *). MonadReader r m => m r
ask
local :: (e -> e) -> F m a -> F m a
local e -> e
f = m a -> F m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> F m a) -> (F m a -> m a) -> F m a -> F m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> e) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f (m a -> m a) -> (F m a -> m a) -> F m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F m a -> m a
forall (m :: * -> *) a. Monad m => F m a -> m a
retract
instance MonadWriter w m => MonadWriter w (F m) where
tell :: w -> F m ()
tell = m () -> F m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> F m ()) -> (w -> m ()) -> w -> F m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
pass :: F m (a, w -> w) -> F m a
pass = m a -> F m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> F m a)
-> (F m (a, w -> w) -> m a) -> F m (a, w -> w) -> F m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w -> w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m (a, w -> w) -> m a)
-> (F m (a, w -> w) -> m (a, w -> w)) -> F m (a, w -> w) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F m (a, w -> w) -> m (a, w -> w)
forall (m :: * -> *) a. Monad m => F m a -> m a
retract
listen :: F m a -> F m (a, w)
listen = m (a, w) -> F m (a, w)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, w) -> F m (a, w))
-> (F m a -> m (a, w)) -> F m a -> F m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m a -> m (a, w)) -> (F m a -> m a) -> F m a -> m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F m a -> m a
forall (m :: * -> *) a. Monad m => F m a -> m a
retract
instance MonadCont m => MonadCont (F m) where
callCC :: ((a -> F m b) -> F m a) -> F m a
callCC (a -> F m b) -> F m a
f = m a -> F m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> F m a) -> m a -> F m a
forall a b. (a -> b) -> a -> b
$ ((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (F m a -> m a
forall (m :: * -> *) a. Monad m => F m a -> m a
retract (F m a -> m a) -> ((a -> m b) -> F m a) -> (a -> m b) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> F m b) -> F m a
f ((a -> F m b) -> F m a)
-> ((a -> m b) -> a -> F m b) -> (a -> m b) -> F m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m b -> F m b) -> (a -> m b) -> a -> F m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m b -> F m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
retract :: Monad m => F m a -> m a
retract :: F m a -> m a
retract (F forall r. (a -> r) -> (m r -> r) -> r
m) = (a -> m a) -> (m (m a) -> m a) -> m a
forall r. (a -> r) -> (m r -> r) -> r
m a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Monad.join
{-# INLINE retract #-}
hoistF :: (forall x. f x -> g x) -> F f a -> F g a
hoistF :: (forall x. f x -> g x) -> F f a -> F g a
hoistF forall x. f x -> g x
t (F forall r. (a -> r) -> (f r -> r) -> r
m) = (forall r. (a -> r) -> (g r -> r) -> r) -> F g a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
p g r -> r
f -> (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
m a -> r
p (g r -> r
f (g r -> r) -> (f r -> g r) -> f r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f r -> g r
forall x. f x -> g x
t))
foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a
foldF :: (forall x. f x -> m x) -> F f a -> m a
foldF forall x. f x -> m x
f (F forall r. (a -> r) -> (f r -> r) -> r
m) = (a -> m a) -> (f (m a) -> m a) -> m a
forall r. (a -> r) -> (f r -> r) -> r
m a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Monad.join (m (m a) -> m a) -> (f (m a) -> m (m a)) -> f (m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (m a) -> m (m a)
forall x. f x -> m x
f)
fromF :: MonadFree f m => F f a -> m a
fromF :: F f a -> m a
fromF (F forall r. (a -> r) -> (f r -> r) -> r
m) = (a -> m a) -> (f (m a) -> m a) -> m a
forall r. (a -> r) -> (f r -> r) -> r
m a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return f (m a) -> m a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap
{-# INLINE fromF #-}
toF :: Functor f => Free f a -> F f a
toF :: Free f a -> F f a
toF Free f a
xs = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
kp f r -> r
kf -> (a -> r) -> (f r -> r) -> Free f a -> r
forall (f :: * -> *) t b.
Functor f =>
(t -> b) -> (f b -> b) -> Free f t -> b
go a -> r
kp f r -> r
kf Free f a
xs) where
go :: (t -> b) -> (f b -> b) -> Free f t -> b
go t -> b
kp f b -> b
_ (Pure t
a) = t -> b
kp t
a
go t -> b
kp f b -> b
kf (Free f (Free f t)
fma) = f b -> b
kf ((Free f t -> b) -> f (Free f t) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t -> b) -> (f b -> b) -> Free f t -> b
go t -> b
kp f b -> b
kf) f (Free f t)
fma)
improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a
improve :: (forall (m :: * -> *). MonadFree f m => m a) -> Free f a
improve forall (m :: * -> *). MonadFree f m => m a
m = F f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF F f a
forall (m :: * -> *). MonadFree f m => m a
m
{-# INLINE improve #-}
{-# INLINE cutoff #-}
cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a)
cutoff :: Integer -> F f a -> F f (Maybe a)
cutoff Integer
n F f a
m
| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Maybe a -> F f (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) = Int -> F f a -> F f (Maybe a)
forall (f :: * -> *) n a.
(Functor f, Integral n) =>
n -> F f a -> F f (Maybe a)
cutoffI (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n :: Int) F f a
m
| Bool
otherwise = Integer -> F f a -> F f (Maybe a)
forall (f :: * -> *) n a.
(Functor f, Integral n) =>
n -> F f a -> F f (Maybe a)
cutoffI Integer
n F f a
m
{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-}
{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-}
cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a)
cutoffI :: n -> F f a -> F f (Maybe a)
cutoffI n
n F f a
m = (forall r. (Maybe a -> r) -> (f r -> r) -> r) -> F f (Maybe a)
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F forall r. (Maybe a -> r) -> (f r -> r) -> r
m' where
m' :: (Maybe a -> b) -> (f b -> b) -> b
m' Maybe a -> b
kp f b -> b
kf = F f a -> (a -> n -> b) -> (f (n -> b) -> n -> b) -> n -> b
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m a -> n -> b
forall a. (Ord a, Num a) => a -> a -> b
kpn f (n -> b) -> n -> b
forall a. (Ord a, Num a) => f (a -> b) -> a -> b
kfn n
n where
kpn :: a -> a -> b
kpn a
a a
i
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = Maybe a -> b
kp Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe a -> b
kp (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
kfn :: f (a -> b) -> a -> b
kfn f (a -> b)
fr a
i
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = Maybe a -> b
kp Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = let
i' :: a
i' = a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
1
in a
i' a -> b -> b
`seq` f b -> b
kf (((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
i') f (a -> b)
fr)