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