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{-# LANGUAGE StandaloneDeriving #-} 10#endif 11#include "free-common.h" 12----------------------------------------------------------------------------- 13-- | 14-- Module : Control.Monad.Free 15-- Copyright : (C) 2008-2015 Edward Kmett 16-- License : BSD-style (see the file LICENSE) 17-- 18-- Maintainer : Edward Kmett <ekmett@gmail.com> 19-- Stability : provisional 20-- Portability : MPTCs, fundeps 21-- 22-- Monads for free 23---------------------------------------------------------------------------- 24module Control.Monad.Free 25 ( MonadFree(..) 26 , Free(..) 27 , retract 28 , liftF 29 , iter 30 , iterA 31 , iterM 32 , hoistFree 33 , foldFree 34 , toFreeT 35 , cutoff 36 , unfold 37 , unfoldM 38 , _Pure, _Free 39 ) where 40 41import Control.Applicative 42import Control.Arrow ((>>>)) 43import Control.Monad (liftM, MonadPlus(..), (>=>)) 44import Control.Monad.Fix 45import Control.Monad.Trans.Class 46import qualified Control.Monad.Trans.Free as FreeT 47import Control.Monad.Free.Class 48import Control.Monad.Reader.Class 49import Control.Monad.Writer.Class 50import Control.Monad.State.Class 51import Control.Monad.Error.Class 52import Control.Monad.Cont.Class 53import Data.Functor.Bind 54import Data.Functor.Classes.Compat 55import Data.Foldable 56import Data.Profunctor 57import Data.Traversable 58import Data.Semigroup.Foldable 59import Data.Semigroup.Traversable 60import Data.Data 61import Prelude hiding (foldr) 62#if __GLASGOW_HASKELL__ >= 707 63import GHC.Generics 64#endif 65 66-- | The 'Free' 'Monad' for a 'Functor' @f@. 67-- 68-- /Formally/ 69-- 70-- A 'Monad' @n@ is a free 'Monad' for @f@ if every monad homomorphism 71-- from @n@ to another monad @m@ is equivalent to a natural transformation 72-- from @f@ to @m@. 73-- 74-- /Why Free?/ 75-- 76-- Every \"free\" functor is left adjoint to some \"forgetful\" functor. 77-- 78-- If we define a forgetful functor @U@ from the category of monads to the category of functors 79-- that just forgets the 'Monad', leaving only the 'Functor'. i.e. 80-- 81-- @U (M,'return','Control.Monad.join') = M@ 82-- 83-- then 'Free' is the left adjoint to @U@. 84-- 85-- 'Free' being left adjoint to @U@ means that there is an isomorphism between 86-- 87-- @'Free' f -> m@ in the category of monads and @f -> U m@ in the category of functors. 88-- 89-- Morphisms in the category of monads are 'Monad' homomorphisms (natural transformations that respect 'return' and 'Control.Monad.join'). 90-- 91-- Morphisms in the category of functors are 'Functor' homomorphisms (natural transformations). 92-- 93-- Given this isomorphism, every monad homomorphism from @'Free' f@ to @m@ is equivalent to a natural transformation from @f@ to @m@ 94-- 95-- Showing that this isomorphism holds is left as an exercise. 96-- 97-- In practice, you can just view a @'Free' f a@ as many layers of @f@ wrapped around values of type @a@, where 98-- @('>>=')@ performs substitution and grafts new layers of @f@ in for each of the free variables. 99-- 100-- This can be very useful for modeling domain specific languages, trees, or other constructs. 101-- 102-- This instance of 'MonadFree' is fairly naive about the encoding. For more efficient free monad implementation see "Control.Monad.Free.Church", in particular note the 'Control.Monad.Free.Church.improve' combinator. 103-- You may also want to take a look at the @kan-extensions@ package (<http://hackage.haskell.org/package/kan-extensions>). 104-- 105-- A number of common monads arise as free monads, 106-- 107-- * Given @data Empty a@, @'Free' Empty@ is isomorphic to the 'Data.Functor.Identity' monad. 108-- 109-- * @'Free' 'Maybe'@ can be used to model a partiality monad where each layer represents running the computation for a while longer. 110data Free f a = Pure a | Free (f (Free f a)) 111#if __GLASGOW_HASKELL__ >= 707 112 deriving (Typeable, Generic, Generic1) 113 114deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) 115#endif 116 117#ifdef LIFTED_FUNCTOR_CLASSES 118instance Eq1 f => Eq1 (Free f) where 119 liftEq eq = go 120 where 121 go (Pure a) (Pure b) = eq a b 122 go (Free fa) (Free fb) = liftEq go fa fb 123 go _ _ = False 124#else 125instance (Functor f, Eq1 f) => Eq1 (Free f) where 126 Pure a `eq1` Pure b = a == b 127 Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb 128 _ `eq1` _ = False 129#endif 130 131#ifdef LIFTED_FUNCTOR_CLASSES 132instance (Eq1 f, Eq a) => Eq (Free f a) where 133#else 134instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where 135#endif 136 (==) = eq1 137 138#ifdef LIFTED_FUNCTOR_CLASSES 139instance Ord1 f => Ord1 (Free f) where 140 liftCompare cmp = go 141 where 142 go (Pure a) (Pure b) = cmp a b 143 go (Pure _) (Free _) = LT 144 go (Free _) (Pure _) = GT 145 go (Free fa) (Free fb) = liftCompare go fa fb 146#else 147instance (Functor f, Ord1 f) => Ord1 (Free f) where 148 Pure a `compare1` Pure b = a `compare` b 149 Pure _ `compare1` Free _ = LT 150 Free _ `compare1` Pure _ = GT 151 Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb 152#endif 153 154#ifdef LIFTED_FUNCTOR_CLASSES 155instance (Ord1 f, Ord a) => Ord (Free f a) where 156#else 157instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where 158#endif 159 compare = compare1 160 161#ifdef LIFTED_FUNCTOR_CLASSES 162instance Show1 f => Show1 (Free f) where 163 liftShowsPrec sp sl = go 164 where 165 go d (Pure a) = showsUnaryWith sp "Pure" d a 166 go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa 167#else 168instance (Functor f, Show1 f) => Show1 (Free f) where 169 showsPrec1 d (Pure a) = showParen (d > 10) $ 170 showString "Pure " . showsPrec 11 a 171 showsPrec1 d (Free m) = showParen (d > 10) $ 172 showString "Free " . showsPrec1 11 (fmap Lift1 m) 173#endif 174 175#ifdef LIFTED_FUNCTOR_CLASSES 176instance (Show1 f, Show a) => Show (Free f a) where 177#else 178instance (Show1 f, Functor f, Show a) => Show (Free f a) where 179#endif 180 showsPrec = showsPrec1 181 182#ifdef LIFTED_FUNCTOR_CLASSES 183instance Read1 f => Read1 (Free f) where 184 liftReadsPrec rp rl = go 185 where 186 go = readsData $ 187 readsUnaryWith rp "Pure" Pure `mappend` 188 readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free 189#else 190instance (Functor f, Read1 f) => Read1 (Free f) where 191 readsPrec1 d r = readParen (d > 10) 192 (\r' -> [ (Pure m, t) 193 | ("Pure", s) <- lex r' 194 , (m, t) <- readsPrec 11 s]) r 195 ++ readParen (d > 10) 196 (\r' -> [ (Free (fmap lower1 m), t) 197 | ("Free", s) <- lex r' 198 , (m, t) <- readsPrec1 11 s]) r 199#endif 200 201#ifdef LIFTED_FUNCTOR_CLASSES 202instance (Read1 f, Read a) => Read (Free f a) where 203#else 204instance (Read1 f, Functor f, Read a) => Read (Free f a) where 205#endif 206 readsPrec = readsPrec1 207 208instance Functor f => Functor (Free f) where 209 fmap f = go where 210 go (Pure a) = Pure (f a) 211 go (Free fa) = Free (go <$> fa) 212 {-# INLINE fmap #-} 213 214instance Functor f => Apply (Free f) where 215 Pure a <.> Pure b = Pure (a b) 216 Pure a <.> Free fb = Free $ fmap a <$> fb 217 Free fa <.> b = Free $ (<.> b) <$> fa 218 219instance Functor f => Applicative (Free f) where 220 pure = Pure 221 {-# INLINE pure #-} 222 Pure a <*> Pure b = Pure $ a b 223 Pure a <*> Free mb = Free $ fmap a <$> mb 224 Free ma <*> b = Free $ (<*> b) <$> ma 225 226instance Functor f => Bind (Free f) where 227 Pure a >>- f = f a 228 Free m >>- f = Free ((>>- f) <$> m) 229 230instance Functor f => Monad (Free f) where 231 return = pure 232 {-# INLINE return #-} 233 Pure a >>= f = f a 234 Free m >>= f = Free ((>>= f) <$> m) 235 236instance Functor f => MonadFix (Free f) where 237 mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" 238 239-- | This violates the Alternative laws, handle with care. 240instance Alternative v => Alternative (Free v) where 241 empty = Free empty 242 {-# INLINE empty #-} 243 a <|> b = Free (pure a <|> pure b) 244 {-# INLINE (<|>) #-} 245 246-- | This violates the MonadPlus laws, handle with care. 247instance (Functor v, MonadPlus v) => MonadPlus (Free v) where 248 mzero = Free mzero 249 {-# INLINE mzero #-} 250 a `mplus` b = Free (return a `mplus` return b) 251 {-# INLINE mplus #-} 252 253-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". 254instance MonadTrans Free where 255 lift = Free . liftM Pure 256 {-# INLINE lift #-} 257 258instance Foldable f => Foldable (Free f) where 259 foldMap f = go where 260 go (Pure a) = f a 261 go (Free fa) = foldMap go fa 262 {-# INLINE foldMap #-} 263 264 foldr f = go where 265 go r free = 266 case free of 267 Pure a -> f a r 268 Free fa -> foldr (flip go) r fa 269 {-# INLINE foldr #-} 270 271#if MIN_VERSION_base(4,6,0) 272 foldl' f = go where 273 go r free = 274 case free of 275 Pure a -> f r a 276 Free fa -> foldl' go r fa 277 {-# INLINE foldl' #-} 278#endif 279 280instance Foldable1 f => Foldable1 (Free f) where 281 foldMap1 f = go where 282 go (Pure a) = f a 283 go (Free fa) = foldMap1 go fa 284 {-# INLINE foldMap1 #-} 285 286instance Traversable f => Traversable (Free f) where 287 traverse f = go where 288 go (Pure a) = Pure <$> f a 289 go (Free fa) = Free <$> traverse go fa 290 {-# INLINE traverse #-} 291 292instance Traversable1 f => Traversable1 (Free f) where 293 traverse1 f = go where 294 go (Pure a) = Pure <$> f a 295 go (Free fa) = Free <$> traverse1 go fa 296 {-# INLINE traverse1 #-} 297 298instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where 299 tell = lift . tell 300 {-# INLINE tell #-} 301 listen = lift . listen . retract 302 {-# INLINE listen #-} 303 pass = lift . pass . retract 304 {-# INLINE pass #-} 305 306instance (Functor m, MonadReader e m) => MonadReader e (Free m) where 307 ask = lift ask 308 {-# INLINE ask #-} 309 local f = lift . local f . retract 310 {-# INLINE local #-} 311 312instance (Functor m, MonadState s m) => MonadState s (Free m) where 313 get = lift get 314 {-# INLINE get #-} 315 put s = lift (put s) 316 {-# INLINE put #-} 317 318instance (Functor m, MonadError e m) => MonadError e (Free m) where 319 throwError = lift . throwError 320 {-# INLINE throwError #-} 321 catchError as f = lift (catchError (retract as) (retract . f)) 322 {-# INLINE catchError #-} 323 324instance (Functor m, MonadCont m) => MonadCont (Free m) where 325 callCC f = lift (callCC (retract . f . liftM lift)) 326 {-# INLINE callCC #-} 327 328instance Functor f => MonadFree f (Free f) where 329 wrap = Free 330 {-# INLINE wrap #-} 331 332-- | 333-- 'retract' is the left inverse of 'lift' and 'liftF' 334-- 335-- @ 336-- 'retract' . 'lift' = 'id' 337-- 'retract' . 'liftF' = 'id' 338-- @ 339retract :: Monad f => Free f a -> f a 340retract (Pure a) = return a 341retract (Free as) = as >>= retract 342 343-- | Tear down a 'Free' 'Monad' using iteration. 344iter :: Functor f => (f a -> a) -> Free f a -> a 345iter _ (Pure a) = a 346iter phi (Free m) = phi (iter phi <$> m) 347 348-- | Like 'iter' for applicative values. 349iterA :: (Applicative p, Functor f) => (f (p a) -> p a) -> Free f a -> p a 350iterA _ (Pure x) = pure x 351iterA phi (Free f) = phi (iterA phi <$> f) 352 353-- | Like 'iter' for monadic values. 354iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a 355iterM _ (Pure x) = return x 356iterM phi (Free f) = phi (iterM phi <$> f) 357 358-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'Free' f@ to @'Free' g@. 359hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b 360hoistFree _ (Pure a) = Pure a 361hoistFree f (Free as) = Free (hoistFree f <$> f as) 362 363-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. 364foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a 365foldFree _ (Pure a) = return a 366foldFree f (Free as) = f as >>= foldFree f 367 368-- | Convert a 'Free' monad from "Control.Monad.Free" to a 'FreeT.FreeT' monad 369-- from "Control.Monad.Trans.Free". 370toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a 371toFreeT (Pure a) = FreeT.FreeT (return (FreeT.Pure a)) 372toFreeT (Free f) = FreeT.FreeT (return (FreeT.Free (fmap toFreeT f))) 373 374-- | Cuts off a tree of computations at a given depth. 375-- If the depth is 0 or less, no computation nor 376-- monadic effects will take place. 377-- 378-- Some examples (n ≥ 0): 379-- 380-- prop> cutoff 0 _ == return Nothing 381-- prop> cutoff (n+1) . return == return . Just 382-- prop> cutoff (n+1) . lift == lift . liftM Just 383-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) 384-- 385-- Calling 'retract . cutoff n' is always terminating, provided each of the 386-- steps in the iteration is terminating. 387cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a) 388cutoff n _ | n <= 0 = return Nothing 389cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f 390cutoff _ m = Just <$> m 391 392-- | Unfold a free monad from a seed. 393unfold :: Functor f => (b -> Either a (f b)) -> b -> Free f a 394unfold f = f >>> either Pure (Free . fmap (unfold f)) 395 396-- | Unfold a free monad from a seed, monadically. 397unfoldM :: (Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) 398unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) 399 400-- | This is @Prism' (Free f a) a@ in disguise 401-- 402-- >>> preview _Pure (Pure 3) 403-- Just 3 404-- 405-- >>> review _Pure 3 :: Free Maybe Int 406-- Pure 3 407_Pure :: forall f m a p. (Choice p, Applicative m) 408 => p a (m a) -> p (Free f a) (m (Free f a)) 409_Pure = dimap impure (either pure (fmap Pure)) . right' 410 where 411 impure (Pure x) = Right x 412 impure x = Left x 413 {-# INLINE impure #-} 414{-# INLINE _Pure #-} 415 416-- | This is @Prism (Free f a) (Free g a) (f (Free f a)) (g (Free g a))@ in disguise 417-- 418-- >>> preview _Free (review _Free (Just (Pure 3))) 419-- Just (Just (Pure 3)) 420-- 421-- >>> review _Free (Just (Pure 3)) 422-- Free (Just (Pure 3)) 423_Free :: forall f g m a p. (Choice p, Applicative m) 424 => p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a)) 425_Free = dimap unfree (either pure (fmap Free)) . right' 426 where 427 unfree (Free x) = Right x 428 unfree (Pure x) = Left (Pure x) 429 {-# INLINE unfree #-} 430{-# INLINE _Free #-} 431 432 433#if __GLASGOW_HASKELL__ < 707 434instance Typeable1 f => Typeable1 (Free f) where 435 typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where 436 f :: Free f a -> f a 437 f = undefined 438 439freeTyCon :: TyCon 440#if __GLASGOW_HASKELL__ < 704 441freeTyCon = mkTyCon "Control.Monad.Free.Free" 442#else 443freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free" 444#endif 445{-# NOINLINE freeTyCon #-} 446 447instance 448 ( Typeable1 f, Typeable a 449 , Data a, Data (f (Free f a)) 450 ) => Data (Free f a) where 451 gfoldl f z (Pure a) = z Pure `f` a 452 gfoldl f z (Free as) = z Free `f` as 453 toConstr Pure{} = pureConstr 454 toConstr Free{} = freeConstr 455 gunfold k z c = case constrIndex c of 456 1 -> k (z Pure) 457 2 -> k (z Free) 458 _ -> error "gunfold" 459 dataTypeOf _ = freeDataType 460 dataCast1 f = gcast1 f 461 462pureConstr, freeConstr :: Constr 463pureConstr = mkConstr freeDataType "Pure" [] Prefix 464freeConstr = mkConstr freeDataType "Free" [] Prefix 465{-# NOINLINE pureConstr #-} 466{-# NOINLINE freeConstr #-} 467 468freeDataType :: DataType 469freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr] 470{-# NOINLINE freeDataType #-} 471 472#endif 473