diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,8 +1,8 @@ name: free category: Control, Monads -version: 3.1.1 +version: 3.2 license: BSD3 -cabal-version: >= 1.6 +cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -35,11 +35,16 @@ library hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + CPP other-extensions: MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances + Rank2Types + GADTs build-depends: base >= 4 && < 5, @@ -56,10 +61,10 @@ if impl(ghc) cpp-options: -DGHC_TYPEABLE - extensions: CPP - exposed-modules: + Control.Applicative.Free Control.Monad.Free + Control.Monad.Free.Church Control.Monad.Free.Class Control.Monad.Trans.Free Control.Comonad.Cofree diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Free.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Free +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- 'Applicative' functors for free +---------------------------------------------------------------------------- +module Control.Applicative.Free + ( Ap(..) + , runAp + , liftAp + , hoistAp + ) where + +import Control.Applicative +import Data.Functor.Apply + +#ifdef GHC_TYPEABLE +import Data.Typeable +#endif + +-- | The free 'Applicative' for a 'Functor' @f@. +data Ap f a where + Pure :: a -> Ap f a + Ap :: f a -> Ap f (a -> b) -> Ap f b + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp _ (Pure x) = pure x +runAp u (Ap f x) = flip id <$> u f <*> runAp u x + +instance Functor (Ap f) where + fmap f (Pure a) = Pure (f a) + fmap f (Ap x y) = Ap x ((f .) <$> y) + +instance Apply (Ap f) where + Pure f <.> y = fmap f y + Ap x y <.> z = Ap x (flip <$> y <.> z) + +instance Applicative (Ap f) where + pure = Pure + Pure f <*> y = fmap f y + Ap x y <*> z = Ap x (flip <$> y <*> z) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp x = Ap x (Pure id) +{-# INLINE liftAp #-} + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b +hoistAp _ (Pure a) = Pure a +hoistAp f (Ap x y) = Ap (f x) (hoistAp f y) +{-# INLINE hoistAp #-} + +#ifdef GHC_TYPEABLE +instance Typeable1 f => Typeable1 (Ap f) where + typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where + f :: Ap f a -> f a + f = undefined + +apTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apTyCon = mkTyCon "Control.Applicative.Free.Ap" +#else +apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap" +#endif +{-# NOINLINE apTyCon #-} + +#endif diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free @@ -14,7 +15,6 @@ -- Portability : MPTCs, fundeps -- -- Monads for free --- ---------------------------------------------------------------------------- module Control.Monad.Free ( MonadFree(..) @@ -22,6 +22,7 @@ , retract , liftF , iter + , hoistFree ) where import Control.Applicative @@ -212,6 +213,12 @@ iter :: Functor f => (f a -> a) -> Free f a -> a iter _ (Pure a) = a iter phi (Free m) = phi (iter phi <$> m) + +-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'FreeT' f@ to @'FreeT' g@. +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) +{-# INLINE hoistFree #-} #ifdef GHC_TYPEABLE instance Typeable1 f => Typeable1 (Free f) where diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Free/Church.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free.Church +-- Copyright : (C) 2011-2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : non-portable (rank-2 polymorphism) +-- +-- \"Free Monads for Less\" +-- +-- This is based on the \"Free Monads for Less\" series of articles: +-- +-- +-- +---------------------------------------------------------------------------- +module Control.Monad.Free.Church + ( F(..) + , improve + , fromF + , toF + , liftF + , retract + ) where + +import Control.Applicative +import Control.Monad as Monad +import Control.Monad.Free hiding (liftF, retract) +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.Functor.Bind + +-- | The Church-encoded free monad for a functor @f@. +-- +-- It is /asymptotically/ more efficient to use ('>>=') for 'F' than it is to ('>>=') with 'Free'. +-- +-- +newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } + +instance Functor (F f) where + fmap f (F g) = F (\kp -> g (kp . f)) + +instance Apply (F f) where + (<.>) = (<*>) + +instance Applicative (F f) where + pure a = F (\kp _ -> kp a) + F f <*> F g = F (\kp kf -> f (\a -> g (\b -> kp (a b)) kf) kf) + +instance Alternative f => Alternative (F f) where + empty = F (\_ kf -> kf empty) + F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf))) + +instance Bind (F f) where + (>>-) = (>>=) + +instance Monad (F f) where + return a = F (\kp _ -> kp a) + F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) + +instance MonadPlus f => MonadPlus (F f) where + mzero = F (\_ kf -> kf mzero) + F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf))) + +instance MonadTrans F where + lift f = F (\kp kf -> kf (liftM kp f)) + +instance Functor f => MonadFree f (F f) where + wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f)) + +instance MonadState s m => MonadState s (F m) where + get = lift get + put = lift . put + +instance MonadReader e m => MonadReader e (F m) where + ask = lift ask + local f = lift . local f . retract + +instance MonadWriter w m => MonadWriter w (F m) where + tell = lift . tell + pass = lift . pass . retract + listen = lift . listen . retract + +instance MonadCont m => MonadCont (F m) where + callCC f = lift $ callCC (retract . f . fmap lift) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftF :: Functor f => f a -> F f a +liftF f = F (\kp kf -> kf (fmap kp f)) +{-# INLINE liftF #-} + +-- | +-- 'retract' is the left inverse of 'lift' and 'liftF' +-- +-- @ +-- 'retract' . 'lift' = 'id' +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad m => F m a -> m a +retract (F m) = m return Monad.join +{-# INLINE retract #-} + +-- | Convert to another free monad representation. +fromF :: MonadFree f m => F f a -> m a +fromF (F m) = m return wrap +{-# INLINE fromF #-} + +-- | Generate a Church-encoded free monad from a 'Free' monad. +toF :: Functor f => Free f a -> F f a +toF xs = F (\kp kf -> go kp kf xs) where + go kp _ (Pure a) = kp a + go kp kf (Free fma) = kf (fmap (go kp kf) fma) + +-- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes. +-- +-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: +-- +-- +-- +-- +-- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: +-- +-- +improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a +improve m = fromF m +{-# INLINE improve #-} diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Free @@ -21,6 +22,8 @@ , FreeT(..) , MonadFree(..) , liftF + , hoistFreeT + , transFreeT ) where import Control.Applicative @@ -66,6 +69,11 @@ bitraverse f _ (Pure a) = Pure <$> f a bitraverse _ g (Free as) = Free <$> traverse g as +transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b +transFreeF _ (Pure a) = Pure a +transFreeF t (Free as) = Free (t as) +{-# INLINE transFreeF #-} + -- | The \"free monad transformer\" for a functor @f@. newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) } @@ -90,42 +98,62 @@ instance (Functor f, Monad m) => Applicative (FreeT f m) where pure a = FreeT (return (Pure a)) + {-# INLINE pure #-} (<*>) = ap + {-# INLINE (<*>) #-} instance (Functor f, Monad m) => Monad (FreeT f m) where return a = FreeT (return (Pure a)) + {-# INLINE return #-} FreeT m >>= f = FreeT $ m >>= \v -> case v of Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>= f) w)) instance MonadTrans (FreeT f) where lift = FreeT . liftM Pure + {-# INLINE lift #-} instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where liftIO = lift . liftIO + {-# INLINE liftIO #-} instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where empty = FreeT mzero FreeT ma <|> FreeT mb = FreeT (mplus ma mb) + {-# INLINE (<|>) #-} instance (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where mzero = FreeT mzero + {-# INLINE mzero #-} mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb) + {-# INLINE mplus #-} instance (Functor f, Monad m) => MonadFree f (FreeT f m) where wrap = FreeT . return . Free + {-# INLINE wrap #-} -- | FreeT is a functor from the category of functors to the category of monads. -- -- This provides the mapping. liftF :: (Functor f, Monad m) => f a -> FreeT f m a liftF = wrap . fmap return +{-# INLINE liftF #-} instance (Foldable m, Foldable f) => Foldable (FreeT f m) where foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m + +-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ +-- +-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ +hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b +hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT + +-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g n@ +transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b +transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT #ifdef GHC_TYPEABLE