1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE UndecidableInstances #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE Rank2Types #-} 6#if __GLASGOW_HASKELL__ >= 707 7{-# LANGUAGE DeriveDataTypeable #-} 8{-# LANGUAGE DeriveGeneric #-} 9#endif 10#include "free-common.h" 11 12-------------------------------------------------------------------------------- 13-- | 14-- \"Applicative Effects in Free Monads\" 15-- 16-- Often times, the '(\<*\>)' operator can be more efficient than 'ap'. 17-- Conventional free monads don't provide any means of modeling this. 18-- The free monad can be modified to make use of an underlying applicative. 19-- But it does require some laws, or else the '(\<*\>)' = 'ap' law is broken. 20-- When interpreting this free monad with 'foldFree', 21-- the natural transformation must be an applicative homomorphism. 22-- An applicative homomorphism @hm :: (Applicative f, Applicative g) => f x -> g x@ 23-- will satisfy these laws. 24-- 25-- * @hm (pure a) = pure a@ 26-- * @hm (f \<*\> a) = hm f \<*\> hm a@ 27-- 28-- This is based on the \"Applicative Effects in Free Monads\" series of articles by Will Fancher 29-- 30-- * <http://elvishjerricco.github.io/2016/04/08/applicative-effects-in-free-monads.html Applicative Effects in Free Monads> 31-- 32-- * <http://elvishjerricco.github.io/2016/04/13/more-on-applicative-effects-in-free-monads.html More on Applicative Effects in Free Monads> 33-------------------------------------------------------------------------------- 34module Control.Monad.Free.Ap 35 ( MonadFree(..) 36 , Free(..) 37 , retract 38 , liftF 39 , iter 40 , iterA 41 , iterM 42 , hoistFree 43 , foldFree 44 , toFreeT 45 , cutoff 46 , unfold 47 , unfoldM 48 , _Pure, _Free 49 ) where 50 51import Control.Applicative 52import Control.Arrow ((>>>)) 53import Control.Monad (liftM, MonadPlus(..), (>=>)) 54import Control.Monad.Fix 55import Control.Monad.Trans.Class 56import qualified Control.Monad.Trans.Free.Ap as FreeT 57import Control.Monad.Free.Class 58import Control.Monad.Reader.Class 59import Control.Monad.Writer.Class 60import Control.Monad.State.Class 61import Control.Monad.Error.Class 62import Control.Monad.Cont.Class 63import Data.Functor.Bind 64import Data.Functor.Classes.Compat 65import Data.Foldable 66import Data.Profunctor 67import Data.Traversable 68import Data.Semigroup.Foldable 69import Data.Semigroup.Traversable 70import Data.Data 71import Prelude hiding (foldr) 72#if __GLASGOW_HASKELL__ >= 707 73import GHC.Generics 74#endif 75 76-- | A free monad given an applicative 77data Free f a = Pure a | Free (f (Free f a)) 78#if __GLASGOW_HASKELL__ >= 707 79 deriving (Typeable, Generic, Generic1) 80#endif 81 82#ifdef LIFTED_FUNCTOR_CLASSES 83instance Eq1 f => Eq1 (Free f) where 84 liftEq eq = go 85 where 86 go (Pure a) (Pure b) = eq a b 87 go (Free fa) (Free fb) = liftEq go fa fb 88 go _ _ = False 89#else 90instance (Functor f, Eq1 f) => Eq1 (Free f) where 91 Pure a `eq1` Pure b = a == b 92 Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb 93 _ `eq1` _ = False 94#endif 95 96#ifdef LIFTED_FUNCTOR_CLASSES 97instance (Eq1 f, Eq a) => Eq (Free f a) where 98#else 99instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where 100#endif 101 (==) = eq1 102 103#ifdef LIFTED_FUNCTOR_CLASSES 104instance Ord1 f => Ord1 (Free f) where 105 liftCompare cmp = go 106 where 107 go (Pure a) (Pure b) = cmp a b 108 go (Pure _) (Free _) = LT 109 go (Free _) (Pure _) = GT 110 go (Free fa) (Free fb) = liftCompare go fa fb 111#else 112instance (Functor f, Ord1 f) => Ord1 (Free f) where 113 Pure a `compare1` Pure b = a `compare` b 114 Pure _ `compare1` Free _ = LT 115 Free _ `compare1` Pure _ = GT 116 Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb 117#endif 118 119#ifdef LIFTED_FUNCTOR_CLASSES 120instance (Ord1 f, Ord a) => Ord (Free f a) where 121#else 122instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where 123#endif 124 compare = compare1 125 126#ifdef LIFTED_FUNCTOR_CLASSES 127instance Show1 f => Show1 (Free f) where 128 liftShowsPrec sp sl = go 129 where 130 go d (Pure a) = showsUnaryWith sp "Pure" d a 131 go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa 132#else 133instance (Functor f, Show1 f) => Show1 (Free f) where 134 showsPrec1 d (Pure a) = showParen (d > 10) $ 135 showString "Pure " . showsPrec 11 a 136 showsPrec1 d (Free m) = showParen (d > 10) $ 137 showString "Free " . showsPrec1 11 (fmap Lift1 m) 138#endif 139 140#ifdef LIFTED_FUNCTOR_CLASSES 141instance (Show1 f, Show a) => Show (Free f a) where 142#else 143instance (Show1 f, Functor f, Show a) => Show (Free f a) where 144#endif 145 showsPrec = showsPrec1 146 147#ifdef LIFTED_FUNCTOR_CLASSES 148instance Read1 f => Read1 (Free f) where 149 liftReadsPrec rp rl = go 150 where 151 go = readsData $ 152 readsUnaryWith rp "Pure" Pure `mappend` 153 readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free 154#else 155instance (Functor f, Read1 f) => Read1 (Free f) where 156 readsPrec1 d r = readParen (d > 10) 157 (\r' -> [ (Pure m, t) 158 | ("Pure", s) <- lex r' 159 , (m, t) <- readsPrec 11 s]) r 160 ++ readParen (d > 10) 161 (\r' -> [ (Free (fmap lower1 m), t) 162 | ("Free", s) <- lex r' 163 , (m, t) <- readsPrec1 11 s]) r 164#endif 165 166#ifdef LIFTED_FUNCTOR_CLASSES 167instance (Read1 f, Read a) => Read (Free f a) where 168#else 169instance (Read1 f, Functor f, Read a) => Read (Free f a) where 170#endif 171 readsPrec = readsPrec1 172 173instance Functor f => Functor (Free f) where 174 fmap f = go where 175 go (Pure a) = Pure (f a) 176 go (Free fa) = Free (go <$> fa) 177 {-# INLINE fmap #-} 178 179instance Apply f => Apply (Free f) where 180 Pure a <.> Pure b = Pure (a b) 181 Pure a <.> Free fb = Free $ fmap a <$> fb 182 Free fa <.> Pure b = Free $ fmap ($ b) <$> fa 183 Free fa <.> Free fb = Free $ fmap (<.>) fa <.> fb 184 185instance Applicative f => Applicative (Free f) where 186 pure = Pure 187 {-# INLINE pure #-} 188 Pure a <*> Pure b = Pure $ a b 189 Pure a <*> Free mb = Free $ fmap a <$> mb 190 Free ma <*> Pure b = Free $ fmap ($ b) <$> ma 191 Free ma <*> Free mb = Free $ fmap (<*>) ma <*> mb 192 193instance Apply f => Bind (Free f) where 194 Pure a >>- f = f a 195 Free m >>- f = Free ((>>- f) <$> m) 196 197instance Applicative f => Monad (Free f) where 198 return = pure 199 {-# INLINE return #-} 200 Pure a >>= f = f a 201 Free m >>= f = Free ((>>= f) <$> m) 202 203instance Applicative f => MonadFix (Free f) where 204 mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" 205 206-- | This violates the Alternative laws, handle with care. 207instance Alternative v => Alternative (Free v) where 208 empty = Free empty 209 {-# INLINE empty #-} 210 a <|> b = Free (pure a <|> pure b) 211 {-# INLINE (<|>) #-} 212 213-- | This violates the MonadPlus laws, handle with care. 214instance (Applicative v, MonadPlus v) => MonadPlus (Free v) where 215 mzero = Free mzero 216 {-# INLINE mzero #-} 217 a `mplus` b = Free (return a `mplus` return b) 218 {-# INLINE mplus #-} 219 220-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". 221instance MonadTrans Free where 222 lift = Free . liftM Pure 223 {-# INLINE lift #-} 224 225instance Foldable f => Foldable (Free f) where 226 foldMap f = go where 227 go (Pure a) = f a 228 go (Free fa) = foldMap go fa 229 {-# INLINE foldMap #-} 230 231 foldr f = go where 232 go r free = 233 case free of 234 Pure a -> f a r 235 Free fa -> foldr (flip go) r fa 236 {-# INLINE foldr #-} 237 238#if MIN_VERSION_base(4,6,0) 239 foldl' f = go where 240 go r free = 241 case free of 242 Pure a -> f r a 243 Free fa -> foldl' go r fa 244 {-# INLINE foldl' #-} 245#endif 246 247instance Foldable1 f => Foldable1 (Free f) where 248 foldMap1 f = go where 249 go (Pure a) = f a 250 go (Free fa) = foldMap1 go fa 251 {-# INLINE foldMap1 #-} 252 253instance Traversable f => Traversable (Free f) where 254 traverse f = go where 255 go (Pure a) = Pure <$> f a 256 go (Free fa) = Free <$> traverse go fa 257 {-# INLINE traverse #-} 258 259instance Traversable1 f => Traversable1 (Free f) where 260 traverse1 f = go where 261 go (Pure a) = Pure <$> f a 262 go (Free fa) = Free <$> traverse1 go fa 263 {-# INLINE traverse1 #-} 264 265instance (Applicative m, MonadWriter e m) => MonadWriter e (Free m) where 266 tell = lift . tell 267 {-# INLINE tell #-} 268 listen = lift . listen . retract 269 {-# INLINE listen #-} 270 pass = lift . pass . retract 271 {-# INLINE pass #-} 272 273instance (Applicative m, MonadReader e m) => MonadReader e (Free m) where 274 ask = lift ask 275 {-# INLINE ask #-} 276 local f = lift . local f . retract 277 {-# INLINE local #-} 278 279instance (Applicative m, MonadState s m) => MonadState s (Free m) where 280 get = lift get 281 {-# INLINE get #-} 282 put s = lift (put s) 283 {-# INLINE put #-} 284 285instance (Applicative m, MonadError e m) => MonadError e (Free m) where 286 throwError = lift . throwError 287 {-# INLINE throwError #-} 288 catchError as f = lift (catchError (retract as) (retract . f)) 289 {-# INLINE catchError #-} 290 291instance (Applicative m, MonadCont m) => MonadCont (Free m) where 292 callCC f = lift (callCC (retract . f . liftM lift)) 293 {-# INLINE callCC #-} 294 295instance Applicative f => MonadFree f (Free f) where 296 wrap = Free 297 {-# INLINE wrap #-} 298 299-- | 300-- 'retract' is the left inverse of 'lift' and 'liftF' 301-- 302-- @ 303-- 'retract' . 'lift' = 'id' 304-- 'retract' . 'liftF' = 'id' 305-- @ 306retract :: (Applicative f, Monad f) => Free f a -> f a 307retract = foldFree id 308 309-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration. 310iter :: Applicative f => (f a -> a) -> Free f a -> a 311iter _ (Pure a) = a 312iter phi (Free m) = phi (iter phi <$> m) 313 314-- | Like 'iter' for applicative values. 315iterA :: (Applicative p, Applicative f) => (f (p a) -> p a) -> Free f a -> p a 316iterA _ (Pure x) = pure x 317iterA phi (Free f) = phi (iterA phi <$> f) 318 319-- | Like 'iter' for monadic values. 320iterM :: (Applicative m, Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a 321iterM _ (Pure x) = return x 322iterM phi (Free f) = phi (iterM phi <$> f) 323 324-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'Free' f@ to @'Free' g@. 325hoistFree :: (Applicative f, Applicative g) => (forall a. f a -> g a) -> Free f b -> Free g b 326hoistFree f = foldFree (liftF . f) 327 328-- | Given an applicative homomorphism, you get a monad homomorphism. 329foldFree :: (Applicative f, Applicative m, Monad m) => (forall x . f x -> m x) -> Free f a -> m a 330foldFree _ (Pure a) = return a 331foldFree f (Free as) = f as >>= foldFree f 332 333-- | Convert a 'Free' monad from "Control.Monad.Free.Ap" to a 'FreeT.FreeT' monad 334-- from "Control.Monad.Trans.Free.Ap". 335-- WARNING: This assumes that 'liftF' is an applicative homomorphism. 336toFreeT :: (Applicative f, Applicative m, Monad m) => Free f a -> FreeT.FreeT f m a 337toFreeT = foldFree liftF 338 339-- | Cuts off a tree of computations at a given depth. 340-- If the depth is 0 or less, no computation nor 341-- monadic effects will take place. 342-- 343-- Some examples (n ≥ 0): 344-- 345-- prop> cutoff 0 _ == return Nothing 346-- prop> cutoff (n+1) . return == return . Just 347-- prop> cutoff (n+1) . lift == lift . liftM Just 348-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) 349-- 350-- Calling 'retract . cutoff n' is always terminating, provided each of the 351-- steps in the iteration is terminating. 352cutoff :: (Applicative f) => Integer -> Free f a -> Free f (Maybe a) 353cutoff n _ | n <= 0 = return Nothing 354cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f 355cutoff _ m = Just <$> m 356 357-- | Unfold a free monad from a seed. 358unfold :: Applicative f => (b -> Either a (f b)) -> b -> Free f a 359unfold f = f >>> either Pure (Free . fmap (unfold f)) 360 361-- | Unfold a free monad from a seed, monadically. 362unfoldM :: (Applicative f, Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) 363unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) 364 365-- | This is @Prism' (Free f a) a@ in disguise 366-- 367-- >>> preview _Pure (Pure 3) 368-- Just 3 369-- 370-- >>> review _Pure 3 :: Free Maybe Int 371-- Pure 3 372_Pure :: forall f m a p. (Choice p, Applicative m) 373 => p a (m a) -> p (Free f a) (m (Free f a)) 374_Pure = dimap impure (either pure (fmap Pure)) . right' 375 where 376 impure (Pure x) = Right x 377 impure x = Left x 378 {-# INLINE impure #-} 379{-# INLINE _Pure #-} 380 381-- | This is @Prism' (Free f a) (f (Free f a))@ in disguise 382-- 383-- >>> preview _Free (review _Free (Just (Pure 3))) 384-- Just (Just (Pure 3)) 385-- 386-- >>> review _Free (Just (Pure 3)) 387-- Free (Just (Pure 3)) 388_Free :: forall f m a p. (Choice p, Applicative m) 389 => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a)) 390_Free = dimap unfree (either pure (fmap Free)) . right' 391 where 392 unfree (Free x) = Right x 393 unfree x = Left x 394 {-# INLINE unfree #-} 395{-# INLINE _Free #-} 396 397 398#if __GLASGOW_HASKELL__ < 707 399instance Typeable1 f => Typeable1 (Free f) where 400 typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where 401 f :: Free f a -> f a 402 f = undefined 403 404freeTyCon :: TyCon 405#if __GLASGOW_HASKELL__ < 704 406freeTyCon = mkTyCon "Control.Monad.Free.Free" 407#else 408freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free" 409#endif 410{-# NOINLINE freeTyCon #-} 411 412instance 413 ( Typeable1 f, Typeable a 414 , Data a, Data (f (Free f a)) 415 ) => Data (Free f a) where 416 gfoldl f z (Pure a) = z Pure `f` a 417 gfoldl f z (Free as) = z Free `f` as 418 toConstr Pure{} = pureConstr 419 toConstr Free{} = freeConstr 420 gunfold k z c = case constrIndex c of 421 1 -> k (z Pure) 422 2 -> k (z Free) 423 _ -> error "gunfold" 424 dataTypeOf _ = freeDataType 425 dataCast1 f = gcast1 f 426 427pureConstr, freeConstr :: Constr 428pureConstr = mkConstr freeDataType "Pure" [] Prefix 429freeConstr = mkConstr freeDataType "Free" [] Prefix 430{-# NOINLINE pureConstr #-} 431{-# NOINLINE freeConstr #-} 432 433freeDataType :: DataType 434freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr] 435{-# NOINLINE freeDataType #-} 436 437#endif 438