1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE Rank2Types #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE UndecidableInstances #-} 6{-# LANGUAGE MultiParamTypeClasses #-} 7{-# LANGUAGE Safe #-} 8#include "free-common.h" 9 10----------------------------------------------------------------------------- 11-- | 12-- Module : Control.Monad.Free.Church 13-- Copyright : (C) 2011-2015 Edward Kmett 14-- License : BSD-style (see the file LICENSE) 15-- 16-- Maintainer : Edward Kmett <ekmett@gmail.com> 17-- Stability : provisional 18-- Portability : non-portable (rank-2 polymorphism) 19-- 20-- \"Free Monads for Less\" 21-- 22-- The most straightforward way of implementing free monads is as a recursive 23-- datatype that allows for arbitrarily deep nesting of the base functor. This is 24-- akin to a tree, with the leaves containing the values, and the nodes being a 25-- level of 'Functor' over subtrees. 26-- 27-- For each time that the `fmap` or `>>=` operations is used, the old tree is 28-- traversed up to the leaves, a new set of nodes is allocated, and 29-- the old ones are garbage collected. Even if the Haskell runtime 30-- optimizes some of the overhead through laziness and generational garbage 31-- collection, the asymptotic runtime is still quadratic. 32-- 33-- On the other hand, if the Church encoding is used, the tree only needs to be 34-- constructed once, because: 35-- 36-- * All uses of `fmap` are collapsed into a single one, so that the values on the 37-- _leaves_ are transformed in one pass. 38-- 39-- prop> fmap f . fmap g == fmap (f . g) 40-- 41-- * All uses of `>>=` are right associated, so that every new subtree created 42-- is final. 43-- 44-- prop> (m >>= f) >>= g == m >>= (\x -> f x >>= g) 45-- 46-- Asymptotically, the Church encoding supports the monadic operations more 47-- efficiently than the naïve 'Free'. 48-- 49-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: 50-- 51-- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1> 52-- 53-- * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> 54---------------------------------------------------------------------------- 55module Control.Monad.Free.Church 56 ( F(..) 57 , improve 58 , fromF 59 , iter 60 , iterM 61 , toF 62 , retract 63 , hoistF 64 , foldF 65 , MonadFree(..) 66 , liftF 67 , cutoff 68 ) where 69 70import Control.Applicative 71import Control.Monad as Monad 72import Control.Monad.Fix 73import Control.Monad.Free hiding (retract, iter, iterM, cutoff) 74import Control.Monad.Reader.Class 75import Control.Monad.Writer.Class 76import Control.Monad.Cont.Class 77import Control.Monad.Trans.Class 78import Control.Monad.State.Class 79import Data.Foldable 80import Data.Traversable 81import Data.Functor.Bind 82import Data.Semigroup.Foldable 83import Data.Semigroup.Traversable 84import Prelude hiding (foldr) 85 86-- | The Church-encoded free monad for a functor @f@. 87-- 88-- It is /asymptotically/ more efficient to use ('>>=') for 'F' than it is to ('>>=') with 'Free'. 89-- 90-- <http://comonad.com/reader/2011/free-monads-for-less-2/> 91newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } 92 93-- | Tear down a 'Free' 'Monad' using iteration. 94iter :: (f a -> a) -> F f a -> a 95iter phi xs = runF xs id phi 96 97-- | Like iter for monadic values. 98iterM :: Monad m => (f (m a) -> m a) -> F f a -> m a 99iterM phi xs = runF xs return phi 100 101instance Functor (F f) where 102 fmap f (F g) = F (\kp -> g (kp . f)) 103 104instance Apply (F f) where 105 (<.>) = (<*>) 106 107instance Applicative (F f) where 108 pure a = F (\kp _ -> kp a) 109 F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf) 110 111-- | This violates the Alternative laws, handle with care. 112instance Alternative f => Alternative (F f) where 113 empty = F (\_ kf -> kf empty) 114 F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf))) 115 116instance Bind (F f) where 117 (>>-) = (>>=) 118 119instance Monad (F f) where 120 return = pure 121 F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) 122 123instance MonadFix (F f) where 124 mfix f = a where 125 a = f (impure a) 126 impure (F x) = x id (error "MonadFix (F f): wrap") 127 128instance Foldable f => Foldable (F f) where 129 foldMap f xs = runF xs f fold 130 {-# INLINE foldMap #-} 131 132 foldr f r xs = runF xs f (foldr (.) id) r 133 {-# INLINE foldr #-} 134 135#if MIN_VERSION_base(4,6,0) 136 foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z 137 {-# INLINE foldl' #-} 138#endif 139 140instance Traversable f => Traversable (F f) where 141 traverse f m = runF m (fmap return . f) (fmap wrap . sequenceA) 142 {-# INLINE traverse #-} 143 144instance Foldable1 f => Foldable1 (F f) where 145 foldMap1 f m = runF m f fold1 146 147instance Traversable1 f => Traversable1 (F f) where 148 traverse1 f m = runF m (fmap return . f) (fmap wrap . sequence1) 149 150-- | This violates the MonadPlus laws, handle with care. 151instance MonadPlus f => MonadPlus (F f) where 152 mzero = F (\_ kf -> kf mzero) 153 F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf))) 154 155instance MonadTrans F where 156 lift f = F (\kp kf -> kf (liftM kp f)) 157 158instance Functor f => MonadFree f (F f) where 159 wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f)) 160 161instance MonadState s m => MonadState s (F m) where 162 get = lift get 163 put = lift . put 164 165instance MonadReader e m => MonadReader e (F m) where 166 ask = lift ask 167 local f = lift . local f . retract 168 169instance MonadWriter w m => MonadWriter w (F m) where 170 tell = lift . tell 171 pass = lift . pass . retract 172 listen = lift . listen . retract 173 174instance MonadCont m => MonadCont (F m) where 175 callCC f = lift $ callCC (retract . f . fmap lift) 176 177-- | 178-- 'retract' is the left inverse of 'lift' and 'liftF' 179-- 180-- @ 181-- 'retract' . 'lift' = 'id' 182-- 'retract' . 'liftF' = 'id' 183-- @ 184retract :: Monad m => F m a -> m a 185retract (F m) = m return Monad.join 186{-# INLINE retract #-} 187 188-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @F f@ to @F g@. 189hoistF :: (forall x. f x -> g x) -> F f a -> F g a 190hoistF t (F m) = F (\p f -> m p (f . t)) 191 192-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. 193foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a 194foldF f (F m) = m return (Monad.join . f) 195 196-- | Convert to another free monad representation. 197fromF :: MonadFree f m => F f a -> m a 198fromF (F m) = m return wrap 199{-# INLINE fromF #-} 200 201-- | Generate a Church-encoded free monad from a 'Free' monad. 202toF :: Functor f => Free f a -> F f a 203toF xs = F (\kp kf -> go kp kf xs) where 204 go kp _ (Pure a) = kp a 205 go kp kf (Free fma) = kf (fmap (go kp kf) fma) 206 207-- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes. 208-- 209-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: 210-- 211-- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1> 212-- 213-- * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> 214-- 215-- and <http://www.iai.uni-bonn.de/~jv/mpc08.pdf \"Asymptotic Improvement of Computations over Free Monads\"> by Janis Voightländer. 216improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a 217improve m = fromF m 218{-# INLINE improve #-} 219 220 221-- | Cuts off a tree of computations at a given depth. 222-- If the depth is 0 or less, no computation nor 223-- monadic effects will take place. 224-- 225-- Some examples (@n ≥ 0@): 226-- 227-- prop> cutoff 0 _ == return Nothing 228-- prop> cutoff (n+1) . return == return . Just 229-- prop> cutoff (n+1) . lift == lift . liftM Just 230-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) 231-- 232-- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the 233-- steps in the iteration is terminating. 234{-# INLINE cutoff #-} 235cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a) 236cutoff n m 237 | n <= 0 = return Nothing 238 | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m 239 | otherwise = cutoffI n m 240 241{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-} 242{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-} 243cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a) 244cutoffI n m = F m' where 245 m' kp kf = runF m kpn kfn n where 246 kpn a i 247 | i <= 0 = kp Nothing 248 | otherwise = kp (Just a) 249 kfn fr i 250 | i <= 0 = kp Nothing 251 | otherwise = let 252 i' = i - 1 253 in i' `seq` kf (fmap ($ i') fr) 254