{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
module Control.Monad.Free
( MonadFree(..)
, Free(..)
, retract
, liftF
, iter
, iterM
, hoistFree
, toFreeT
, cutoff
, _Pure, _Free
) where
import Control.Applicative
import Control.Monad (liftM, MonadPlus(..))
import Control.Monad.Fix
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.Free as FreeT
import Control.Monad.Free.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.Error.Class
import Control.Monad.Cont.Class
import Data.Functor.Bind
import Data.Foldable
import Data.Profunctor
import Data.Traversable
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Data
import Prelude hiding (foldr)
import Prelude.Extras
data Free f a = Pure a | Free (f (Free f a))
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#endif
instance (Functor f, Eq1 f) => Eq1 (Free f) where
Pure a ==# Pure b = a == b
Free fa ==# Free fb = fmap Lift1 fa ==# fmap Lift1 fb
_ ==# _ = False
instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where
Pure a == Pure b = a == b
Free fa == Free fb = fa == fb
_ == _ = False
instance (Functor f, Ord1 f) => Ord1 (Free f) where
Pure a `compare1` Pure b = a `compare` b
Pure _ `compare1` Free _ = LT
Free _ `compare1` Pure _ = GT
Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb
instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where
Pure a `compare` Pure b = a `compare` b
Pure _ `compare` Free _ = LT
Free _ `compare` Pure _ = GT
Free fa `compare` Free fb = fa `compare` fb
instance (Functor f, Show1 f) => Show1 (Free f) where
showsPrec1 d (Pure a) = showParen (d > 10) $
showString "Pure " . showsPrec 11 a
showsPrec1 d (Free m) = showParen (d > 10) $
showString "Free " . showsPrec1 11 (fmap Lift1 m)
instance (Show (f (Free f a)), Show a) => Show (Free f a) where
showsPrec d (Pure a) = showParen (d > 10) $
showString "Pure " . showsPrec 11 a
showsPrec d (Free m) = showParen (d > 10) $
showString "Free " . showsPrec 11 m
instance (Functor f, Read1 f) => Read1 (Free f) where
readsPrec1 d r = readParen (d > 10)
(\r' -> [ (Pure m, t)
| ("Pure", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
++ readParen (d > 10)
(\r' -> [ (Free (fmap lower1 m), t)
| ("Free", s) <- lex r'
, (m, t) <- readsPrec1 11 s]) r
instance (Read (f (Free f a)), Read a) => Read (Free f a) where
readsPrec d r = readParen (d > 10)
(\r' -> [ (Pure m, t)
| ("Pure", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
++ readParen (d > 10)
(\r' -> [ (Free m, t)
| ("Free", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
instance Functor f => Functor (Free f) where
fmap f = go where
go (Pure a) = Pure (f a)
go (Free fa) = Free (go <$> fa)
{-# INLINE fmap #-}
instance Functor f => Apply (Free f) where
Pure a <.> Pure b = Pure (a b)
Pure a <.> Free fb = Free $ fmap a <$> fb
Free fa <.> b = Free $ (<.> b) <$> fa
instance Functor f => Applicative (Free f) where
pure = Pure
{-# INLINE pure #-}
Pure a <*> Pure b = Pure $ a b
Pure a <*> Free mb = Free $ fmap a <$> mb
Free ma <*> b = Free $ (<*> b) <$> ma
instance Functor f => Bind (Free f) where
Pure a >>- f = f a
Free m >>- f = Free ((>>- f) <$> m)
instance Functor f => Monad (Free f) where
return = Pure
{-# INLINE return #-}
Pure a >>= f = f a
Free m >>= f = Free ((>>= f) <$> m)
instance Functor f => MonadFix (Free f) where
mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free"
instance Alternative v => Alternative (Free v) where
empty = Free empty
{-# INLINE empty #-}
a <|> b = Free (pure a <|> pure b)
{-# INLINE (<|>) #-}
instance (Functor v, MonadPlus v) => MonadPlus (Free v) where
mzero = Free mzero
{-# INLINE mzero #-}
a `mplus` b = Free (return a `mplus` return b)
{-# INLINE mplus #-}
instance MonadTrans Free where
lift = Free . liftM Pure
{-# INLINE lift #-}
instance Foldable f => Foldable (Free f) where
foldMap f = go where
go (Pure a) = f a
go (Free fa) = foldMap go fa
{-# INLINE foldMap #-}
foldr f = go where
go r free =
case free of
Pure a -> f a r
Free fa -> foldr (flip go) r fa
{-# INLINE foldr #-}
#if MIN_VERSION_base(4,6,0)
foldl' f = go where
go r free =
case free of
Pure a -> f r a
Free fa -> foldl' go r fa
{-# INLINE foldl' #-}
#endif
instance Foldable1 f => Foldable1 (Free f) where
foldMap1 f = go where
go (Pure a) = f a
go (Free fa) = foldMap1 go fa
{-# INLINE foldMap1 #-}
instance Traversable f => Traversable (Free f) where
traverse f = go where
go (Pure a) = Pure <$> f a
go (Free fa) = Free <$> traverse go fa
{-# INLINE traverse #-}
instance Traversable1 f => Traversable1 (Free f) where
traverse1 f = go where
go (Pure a) = Pure <$> f a
go (Free fa) = Free <$> traverse1 go fa
{-# INLINE traverse1 #-}
instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where
tell = lift . tell
{-# INLINE tell #-}
listen = lift . listen . retract
{-# INLINE listen #-}
pass = lift . pass . retract
{-# INLINE pass #-}
instance (Functor m, MonadReader e m) => MonadReader e (Free m) where
ask = lift ask
{-# INLINE ask #-}
local f = lift . local f . retract
{-# INLINE local #-}
instance (Functor m, MonadState s m) => MonadState s (Free m) where
get = lift get
{-# INLINE get #-}
put s = lift (put s)
{-# INLINE put #-}
instance (Functor m, MonadError e m) => MonadError e (Free m) where
throwError = lift . throwError
{-# INLINE throwError #-}
catchError as f = lift (catchError (retract as) (retract . f))
{-# INLINE catchError #-}
instance (Functor m, MonadCont m) => MonadCont (Free m) where
callCC f = lift (callCC (retract . f . liftM lift))
{-# INLINE callCC #-}
instance Functor f => MonadFree f (Free f) where
wrap = Free
{-# INLINE wrap #-}
retract :: Monad f => Free f a -> f a
retract (Pure a) = return a
retract (Free as) = as >>= retract
iter :: Functor f => (f a -> a) -> Free f a -> a
iter _ (Pure a) = a
iter phi (Free m) = phi (iter phi <$> m)
iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a
iterM _ (Pure x) = return x
iterM phi (Free f) = phi $ fmap (iterM phi) f
hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b
hoistFree _ (Pure a) = Pure a
hoistFree f (Free as) = Free (hoistFree f <$> f as)
toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a
toFreeT (Pure a) = FreeT.FreeT (return (FreeT.Pure a))
toFreeT (Free f) = FreeT.FreeT (return (FreeT.Free (fmap toFreeT f)))
cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a)
cutoff 0 _ = return Nothing
cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f
cutoff _ m = Just <$> m
_Pure :: forall f m a p. (Choice p, Applicative m)
=> p a (m a) -> p (Free f a) (m (Free f a))
_Pure = dimap impure (either pure (fmap Pure)) . right'
where
impure (Pure x) = Right x
impure x = Left x
{-# INLINE impure #-}
{-# INLINE _Pure #-}
_Free :: forall f m a p. (Choice p, Applicative m)
=> p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a))
_Free = dimap unfree (either pure (fmap Free)) . right'
where
unfree (Free x) = Right x
unfree x = Left x
{-# INLINE unfree #-}
{-# INLINE _Free #-}
#if __GLASGOW_HASKELL__ < 707
instance Typeable1 f => Typeable1 (Free f) where
typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where
f :: Free f a -> f a
f = undefined
freeTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
freeTyCon = mkTyCon "Control.Monad.Free.Free"
#else
freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free"
#endif
{-# NOINLINE freeTyCon #-}
instance
( Typeable1 f, Typeable a
, Data a, Data (f (Free f a))
) => Data (Free f a) where
gfoldl f z (Pure a) = z Pure `f` a
gfoldl f z (Free as) = z Free `f` as
toConstr Pure{} = pureConstr
toConstr Free{} = freeConstr
gunfold k z c = case constrIndex c of
1 -> k (z Pure)
2 -> k (z Free)
_ -> error "gunfold"
dataTypeOf _ = freeDataType
dataCast1 f = gcast1 f
pureConstr, freeConstr :: Constr
pureConstr = mkConstr freeDataType "Pure" [] Prefix
freeConstr = mkConstr freeDataType "Free" [] Prefix
{-# NOINLINE pureConstr #-}
{-# NOINLINE freeConstr #-}
freeDataType :: DataType
freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr]
{-# NOINLINE freeDataType #-}
#endif