free 3.2 → 3.3

raw patch · 6 files changed

+508/−35 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• free.cabal +3/−1
• src/Control/Alternative/Free.hs +112/−0
• src/Control/Applicative/Free.hs +0/−1
• src/Control/Comonad/Cofree.hs +57/−21
• src/Control/Monad/Free.hs +40/−12
• src/Control/MonadPlus/Free.hs +296/−0

@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       3.2+version:       3.3 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -63,10 +63,12 @@    exposed-modules:     Control.Applicative.Free+    Control.Alternative.Free     Control.Monad.Free     Control.Monad.Free.Church     Control.Monad.Free.Class     Control.Monad.Trans.Free+    Control.MonadPlus.Free     Control.Comonad.Cofree     Control.Comonad.Cofree.Class     Control.Comonad.Trans.Cofree

@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Alternative.Free+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- Left distributive 'Alternative' functors for free, based on a design+-- by Stijn van Drongelen.+----------------------------------------------------------------------------+module Control.Alternative.Free+  ( Alt(..)+  , runAlt+  , liftAlt+  , hoistAlt+  ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Semigroup++#ifdef GHC_TYPEABLE+import Data.Typeable+#endif++-- | The free 'Applicative' for a 'Functor' @f@.+data Alt f a where+  Pure :: a -> Alt f a+  Ap   :: f a -> Alt f (a -> b) -> Alt f b+  Alt  :: [Alt f a] -> Alt f a++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+runAlt :: Alternative g => (forall x. f x -> g x) -> Alt f a -> g a+runAlt _ (Pure x) = pure x+runAlt u (Ap f x) = flip id <$> u f <*> runAlt u x+runAlt u (Alt as) = foldr (\a r -> runAlt u a <|> r) empty as++instance Functor (Alt f) where+  fmap f (Pure a)   = Pure (f a)+  fmap f (Ap x y)   = Ap x ((f .) <$> y)+  fmap f (Alt as)   = Alt (fmap f <$> as)++instance Apply (Alt f) where+  Pure f <.> y = fmap f y+  Ap x y <.> z = Ap x (flip <$> y <.> z)+  Alt as <.> z = Alt (map (<.> z) as) -- This assumes 'left distribution'++instance Applicative (Alt f) where+  pure = Pure+  Pure f <*> y = fmap f y+  Ap x y <*> z = Ap x (flip <$> y <*> z)+  Alt as <*> z = Alt (map (<*> z) as) -- This assumes 'left distribution'++instance Alternative (Alt f) where+  empty = Alt []+  {-# INLINE empty #-}+  Alt [] <|> r      = r+  l      <|> Alt [] = l+  Alt as <|> Alt bs = Alt (as ++ bs)+  l      <|> r      = Alt [l, r]+  {-# INLINE (<|>) #-}++instance Semigroup (Alt f a) where+  (<>) = (<|>)+  {-# INLINE (<>) #-}++instance Monoid (Alt f a) where+  mempty = empty+  {-# INLINE mempty #-}+  mappend = (<|>)+  {-# INLINE mappend #-}+  mconcat as = fromList (as >>= toList)+    where+      toList (Alt xs) = xs+      toList x       = [x]+      fromList [x] = x+      fromList xs  = Alt xs+  {-# INLINE mconcat #-}++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAlt :: f a -> Alt f a+liftAlt x = Ap x (Pure id)+{-# INLINE liftAlt #-}++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b+hoistAlt _ (Pure a) = Pure a+hoistAlt f (Ap x y) = Ap (f x) (hoistAlt f y)+hoistAlt f (Alt as) = Alt (map (hoistAlt f) as)++#ifdef GHC_TYPEABLE+instance Typeable1 f => Typeable1 (Alt f) where+  typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where+    f :: Alt f a -> f a+    f = undefined++altTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+altTyCon = mkTyCon "Control.Alternative.Free.Alt"+#else+altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt"+#endif+{-# NOINLINE altTyCon #-}++#endif

@@ -60,7 +60,6 @@ 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

@@ -23,8 +23,8 @@   , coiter   , unfold   -- * Lenses into cofree comonads-  , extracted-  , unwrapped+  , _extract+  , _unwrap   , telescoped   ) where @@ -97,6 +97,7 @@  instance Functor f => ComonadCofree f (Cofree f) where   unwrap (_ :< as) = as+  {-# INLINE unwrap #-}  instance Distributive f => Distributive (Cofree f) where   distribute w = fmap extract w :< fmap distribute (collect unwrap w)@@ -107,17 +108,27 @@  instance Functor f => Extend (Cofree f) where   extended = extend+  {-# INLINE extended #-}   duplicated = duplicate+  {-# INLINE duplicated #-}  instance Functor f => Comonad (Cofree f) where   extend f w = f w :< fmap (extend f) (unwrap w)   duplicate w = w :< fmap duplicate (unwrap w)   extract (a :< _) = a+  {-# INLINE extract #-}  -- | This is not a true 'Comonad' transformer, but this instance is convenient. instance ComonadTrans Cofree where   lower (_ :< as) = fmap extract as+  {-# INLINE lower #-} +instance Alternative f => Monad (Cofree f) where+  return x = x :< empty+  {-# INLINE return #-}+  (a :< m) >>= k = case k a of+                     b :< n -> b :< (n <|> fmap (>>= k) m)+ -- | -- -- @'lower' . 'section' = 'id'@@@ -126,19 +137,28 @@  instance Apply f => Apply (Cofree f) where   (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as)+  {-# INLINE (<.>) #-}   (f :< fs) <.  (_ :< as) = f :< ((<. ) <$> fs <.> as)+  {-# INLINE (<.) #-}   (_ :< fs)  .> (a :< as) = a :< (( .>) <$> fs <.> as)+  {-# INLINE (.>) #-}  instance ComonadApply f => ComonadApply (Cofree f) where   (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as)+  {-# INLINE (<@>) #-}   (f :< fs) <@  (_ :< as) = f :< ((<@ ) <$> fs <@> as)+  {-# INLINE (<@) #-}   (_ :< fs)  @> (a :< as) = a :< (( @>) <$> fs <@> as)+  {-# INLINE (@>) #-}  instance Applicative f => Applicative (Cofree f) where   pure a = as where as = a :< pure as   (f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as)+  {-# INLINE (<*>) #-}   (f :< fs) <*  (_ :< as) = f :< ((<* ) <$> fs <*> as)+  {-# INLINE (<*) #-}   (_ :< fs)  *> (a :< as) = a :< (( *>) <$> fs <*> as)+  {-# INLINE (*>) #-}  instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where   showsPrec d (a :< as) = showParen (d > 5) $@@ -161,16 +181,24 @@     GT -> GT  instance Foldable f => Foldable (Cofree f) where-  foldMap f (a :< as) = f a `mappend` foldMap (foldMap f) as+  foldMap f = go where+    go (a :< as) = f a `mappend` foldMap go as+  {-# INLINE foldMap #-}  instance Foldable1 f => Foldable1 (Cofree f) where-  foldMap1 f (a :< as) = f a <> foldMap1 (foldMap1 f) as+  foldMap1 f = go where+    go (a :< as) = f a <> foldMap1 go as+  {-# INLINE foldMap1 #-}  instance Traversable f => Traversable (Cofree f) where-  traverse f (a :< as) = (:<) <$> f a <*> traverse (traverse f) as+  traverse f = go where+    go (a :< as) = (:<) <$> f a <*> traverse go as+  {-# INLINE traverse #-}  instance Traversable1 f => Traversable1 (Cofree f) where-  traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 (traverse1 f) as+  traverse1 f = go where+    go (a :< as) = (:<) <$> f a <.> traverse1 go as+  {-# INLINE traverse1 #-}  #ifdef GHC_TYPEABLE instance (Typeable1 f) => Typeable1 (Cofree f) where@@ -214,43 +242,51 @@  instance ComonadEnv e w => ComonadEnv e (Cofree w) where   ask = ask . lower+  {-# INLINE ask #-}  instance ComonadStore s w => ComonadStore s (Cofree w) where   pos (_ :< as) = Class.pos as+  {-# INLINE pos #-}   peek s (_ :< as) = extract (Class.peek s as)+  {-# INLINE peek #-}  instance ComonadTraced m w => ComonadTraced m (Cofree w) where   trace m = trace m . lower+  {-# INLINE trace #-}  -- | This is a lens that can be used to read or write from the target of 'extract'. ----- @foo ^. 'extracted' == 'extract' foo@+-- Using (^.) from the @lens@ package: ----- For more on lenses see the 'lens' package on hackage+-- @foo ^. '_extract' == 'extract' foo@ ----- @extracted :: Simple Lens (Cofree g a) a@-extracted :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)-extracted f (a :< as) = (:< as) <$> f a-{-# INLINE extracted #-}+-- For more on lenses see the @lens@ package on hackage+--+-- @'_extract' :: Lens' ('Cofree' g a) a@+_extract :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)+_extract f (a :< as) = (:< as) <$> f a+{-# INLINE _extract #-}  -- | This is a lens that can be used to read or write to the tails of a 'Cofree' 'Comonad'. ----- @foo ^. 'unwrapped' == 'unwrap' foo@+-- Using (^.) from the @lens@ package: ----- For more on lenses see the 'lens' package on hackage+-- @foo ^. '_unwrap' == 'unwrap' foo@ ----- @unwrapped :: Simple Lens (Cofree g a) (g (Cofree g a))@-unwrapped :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)-unwrapped  f (a :< as) = (a :<) <$> f as-{-# INLINE unwrapped #-}+-- For more on lenses see the @lens@ package on hackage+--+-- @'_unwrap' :: Lens' ('Cofree' g a) (g ('Cofree' g a))@+_unwrap :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)+_unwrap  f (a :< as) = (a :<) <$> f as+{-# INLINE _unwrap #-}  -- | Construct a @Lens@ into a @'Cofree' f@ given a list of lenses into the base functor. -- -- For more on lenses see the 'lens' package on hackage. ----- @telescoped :: Functor g => [Rep g] -> Simple Lens (Cofree g a) a@+-- @telescoped :: 'Functor' g => [Lens' ('Cofree' g a) (g ('Cofree' g a))] -> Lens' ('Cofree' g a) a@ telescoped :: (Functor f, Functor g) =>              [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->               (a -> f a) -> Cofree g a -> f (Cofree g a)-telescoped [] = extracted-telescoped (l:ls) = unwrapped . l . telescoped ls+telescoped = Prelude.foldr (\l r -> _unwrap . l . r) _extract+{-# INLINE telescoped #-}

@@ -118,8 +118,10 @@              , (m, t) <- readsPrec 11 s]) r  instance Functor f => Functor (Free f) where-  fmap f (Pure a)  = Pure (f a)-  fmap f (Free fa) = Free (fmap f <$> fa)+  fmap f = go where+    go (Pure a)  = Pure (f a)+    go (Free fa) = Free (go <$> fa)+  {-# INLINE fmap #-}  instance Functor f => Apply (Free f) where   Pure a  <.> Pure b = Pure (a b)@@ -128,6 +130,7 @@  instance Functor f => Applicative (Free f) where   pure = Pure+  {-# INLINE pure #-}   Pure a <*> Pure b = Pure $ a b   Pure a <*> Free mb = Free $ fmap a <$> mb   Free ma <*> b = Free $ (<*> b) <$> ma@@ -138,65 +141,91 @@  instance Functor f => Monad (Free f) where   return = Pure+  {-# INLINE return #-}   Pure a >>= f = f a   Free m >>= f = Free ((>>= f) <$> m)  -- | This violates the Alternative laws, handle with care. instance Alternative v => Alternative (Free v) where   empty = Free empty+  {-# INLINE empty #-}   a <|> b = Free (pure a <|> pure b)+  {-# INLINE (<|>) #-}  -- | This violates the MonadPlus laws, handle with care. instance (Functor v, MonadPlus v) => MonadPlus (Free v) where   mzero = Free mzero+  {-# INLINE mzero #-}   a `mplus` b = Free (return a `mplus` return b)+  {-# INLINE mplus #-}  -- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". instance MonadTrans Free where   lift = Free . liftM Pure+  {-# INLINE lift #-}  instance Foldable f => Foldable (Free f) where-  foldMap f (Pure a) = f a-  foldMap f (Free fa) = foldMap (foldMap f) fa+  foldMap f = go where+    go (Pure a) = f a+    go (Free fa) = foldMap go fa+  {-# INLINE foldMap #-}  instance Foldable1 f => Foldable1 (Free f) where-  foldMap1 f (Pure a) = f a-  foldMap1 f (Free fa) = foldMap1 (foldMap1 f) fa+  foldMap1 f = go where+    go (Pure a) = f a+    go (Free fa) = foldMap1 go fa+  {-# INLINE foldMap1 #-}  instance Traversable f => Traversable (Free f) where-  traverse f (Pure a) = Pure <$> f a-  traverse f (Free fa) = Free <$> traverse (traverse f) fa+  traverse f = go where+    go (Pure a) = Pure <$> f a+    go (Free fa) = Free <$> traverse go fa+  {-# INLINE traverse #-}  instance Traversable1 f => Traversable1 (Free f) where-  traverse1 f (Pure a) = Pure <$> f a-  traverse1 f (Free fa) = Free <$> traverse1 (traverse1 f) fa+  traverse1 f = go where+    go (Pure a) = Pure <$> f a+    go (Free fa) = Free <$> traverse1 go fa+  {-# INLINE traverse1 #-}  instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where   tell = lift . tell+  {-# INLINE tell #-}   listen = lift . listen . retract+  {-# INLINE listen #-}   pass = lift . pass . retract+  {-# INLINE pass #-}  instance (Functor m, MonadReader e m) => MonadReader e (Free m) where   ask = lift ask+  {-# INLINE ask #-}   local f = lift . local f . retract+  {-# INLINE local #-}  instance (Functor m, MonadState s m) => MonadState s (Free m) where   get = lift get+  {-# INLINE get #-}   put s = lift (put s)+  {-# INLINE put #-}  instance (Functor m, MonadError e m) => MonadError e (Free m) where   throwError = lift . throwError+  {-# INLINE throwError #-}   catchError as f = lift (catchError (retract as) (retract . f))+  {-# INLINE catchError #-}  instance (Functor m, MonadCont m) => MonadCont (Free m) where   callCC f = lift (callCC (retract . f . liftM lift))+  {-# INLINE callCC #-}  -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftF :: Functor f => f a -> Free f a liftF = Free . fmap Pure+{-# INLINE liftF #-}  instance Functor f => MonadFree f (Free f) where   wrap = Free+  {-# INLINE wrap #-}  -- | -- 'retract' is the left inverse of 'lift' and 'liftF'@@ -216,9 +245,8 @@  -- | 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 _ (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

@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.MonadPlus.Free+-- Copyright   :  (C) 2008-2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  MPTCs, fundeps+--+-- left-distributive MonadPlus for free.+----------------------------------------------------------------------------+module Control.MonadPlus.Free+  ( MonadFree(..)+  , Free(..)+  , retract+  , liftF+  , iter+  , hoistFree+  ) where++import Control.Applicative+import Control.Monad (liftM, MonadPlus(..))+import Control.Monad.Trans.Class+import Control.Monad.Free.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Semigroup++#ifdef GHC_TYPEABLE+import Data.Data+#endif++-- | The 'Free' 'MonadPlus' for a 'Functor' @f@.+--+-- /Formally/+--+-- A 'MonadPlus' @n@ is a free 'MonadPlus' for @f@ if every monadplus homomorphism+-- from @n@ to another MonadPlus @m@ is equivalent to a natural transformation+-- from @f@ to @m@.+--+-- We model this internally as if left-distribution holds.+--+-- <<http://www.haskell.org/haskellwiki/MonadPlus>>+data Free f a+  = Pure a+  | Free (f (Free f a))+  | Plus [Free f a]++instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where+  Pure a == Pure b = a == b+  Free fa == Free fb = fa == fb+  Plus as == Plus bs = as == bs+  _ == _ = False++instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where+  Pure a `compare` Pure b = a `compare` b+  Pure _ `compare` Free _ = LT+  Pure _ `compare` Plus _ = LT+  Free _ `compare` Pure _ = GT+  Free fa `compare` Free fb = fa `compare` fb+  Free _ `compare` Plus _ = LT+  Plus _ `compare` Pure _ = GT+  Plus _ `compare` Free _ = GT+  Plus as `compare` Plus bs = as `compare` bs++instance (Show (f (Free f a)), Show a) => Show (Free f a) where+  showsPrec d (Pure a) = showParen (d > 10) $+    showString "Pure " . showsPrec 11 a+  showsPrec d (Free m) = showParen (d > 10) $+    showString "Free " . showsPrec 11 m+  showsPrec d (Plus as) = showParen (d > 10) $+    showString "Plus " . showsPrec 11 as++instance (Read (f (Free f a)), Read a) => Read (Free f a) where+  readsPrec d r = readParen (d > 10)+      (\r' -> [ (Pure m, t)+             | ("Pure", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Free m, t)+             | ("Free", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Plus as, t)+             | ("Plus", s) <- lex r'+             , (as, t) <- readsPrec 11 s]) r++instance Functor f => Functor (Free f) where+  fmap f = go where+    go (Pure a)  = Pure (f a)+    go (Free fa) = Free (go <$> fa)+    go (Plus as) = Plus (map go as)+  {-# INLINE fmap #-}++instance Functor f => Apply (Free f) where+  Pure f  <.> Pure b = Pure (f b)+  Pure f  <.> Plus bs = Plus $ fmap f <$> bs+  Pure f  <.> Free fb = Free $ fmap f <$> fb+  Free ff <.> b = Free $ (<.> b) <$> ff+  Plus fs <.> b = Plus $ (<.> b) <$> fs -- left distribution ???++instance Functor f => Applicative (Free f) where+  pure = Pure+  {-# INLINE pure #-}+  Pure f  <*> Pure b  = Pure (f b)+  Pure f  <*> Free mb = Free $ fmap f <$> mb+  Pure f  <*> Plus bs = Plus $ fmap f <$> bs+  Free ff <*> b = Free $ (<*> b) <$> ff+  Plus fs <*> b = Plus $ (<*> b) <$> fs -- left distribution++instance Functor f => Bind (Free f) where+  Pure a >>- f = f a+  Free m >>- f = Free ((>>- f) <$> m)+  Plus m >>- f = Plus ((>>- f) <$> m)++instance Functor f => Monad (Free f) where+  return = Pure+  {-# INLINE return #-}+  Pure a >>= f = f a+  Free m >>= f = Free ((>>= f) <$> m)+  Plus m >>= f = Plus (map (>>= f) m) -- left distribution law++instance Functor f => Alternative (Free f) where+  empty = Plus []+  {-# INLINE empty #-}+  Plus [] <|> r       = r+  l       <|> Plus [] = l+  Plus as <|> Plus bs = Plus (as ++ bs)+  a       <|> b       = Plus [a, b]+  {-# INLINE (<|>) #-}++instance Functor f => MonadPlus (Free f) where+  mzero = empty+  {-# INLINE mzero #-}+  mplus = (<|>)+  {-# INLINE mplus #-}++instance Functor f => Semigroup (Free f a) where+  (<>) = (<|>)+  {-# INLINE (<>) #-}++instance Functor f => Monoid (Free f a) where+  mempty = empty+  {-# INLINE mempty #-}+  mappend = (<|>)+  {-# INLINE mappend #-}+  mconcat as = from (as >>= to)+    where+      to (Plus xs) = xs+      to x       = [x]+      from [x] = x+      from xs  = Plus xs+  {-# INLINE mconcat #-}++-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\".+instance MonadTrans Free where+  lift = Free . liftM Pure+  {-# INLINE lift #-}++instance Foldable f => Foldable (Free f) where+  foldMap f = go where+    go (Pure a) = f a+    go (Free fa) = foldMap go fa+    go (Plus as) = foldMap go as+  {-# INLINE foldMap #-}++instance Traversable f => Traversable (Free f) where+  traverse f = go where+    go (Pure a) = Pure <$> f a+    go (Free fa) = Free <$> traverse go fa+    go (Plus as) = Plus <$> traverse go as+  {-# INLINE traverse #-}++instance (Functor m, MonadPlus m, MonadWriter e m) => MonadWriter e (Free m) where+  tell = lift . tell+  {-# INLINE tell #-}+  listen = lift . listen . retract+  {-# INLINE listen #-}+  pass = lift . pass . retract+  {-# INLINE pass #-}++instance (Functor m, MonadPlus m, MonadReader e m) => MonadReader e (Free m) where+  ask = lift ask+  {-# INLINE ask #-}+  local f = lift . local f . retract+  {-# INLINE local #-}++instance (Functor m, MonadState s m) => MonadState s (Free m) where+  get = lift get+  {-# INLINE get #-}+  put s = lift (put s)+  {-# INLINE put #-}++instance (Functor m, MonadPlus m, MonadError e m) => MonadError e (Free m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}+  catchError as f = lift (catchError (retract as) (retract . f))+  {-# INLINE catchError #-}++instance (Functor m, MonadPlus m, MonadCont m) => MonadCont (Free m) where+  callCC f = lift (callCC (retract . f . liftM lift))+  {-# INLINE callCC #-}++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftF :: Functor f => f a -> Free f a+liftF = Free . fmap Pure+{-# INLINE liftF #-}++instance Functor f => MonadFree f (Free f) where+  wrap = Free+  {-# INLINE wrap #-}++-- |+-- 'retract' is the left inverse of 'lift' and 'liftF'+--+-- @+-- 'retract' . 'lift' = 'id'+-- 'retract' . 'liftF' = 'id'+-- @+retract :: MonadPlus f => Free f a -> f a+retract (Pure a) = return a+retract (Free as) = as >>= retract+retract (Plus as) = Prelude.foldr (mplus . retract) mzero as++-- | Tear down a 'Free' 'Monad' using iteration.+iter :: Functor f => (f a -> a) -> ([a] -> a) -> Free f a -> a+iter phi psi = go where+  go (Pure a) = a+  go (Free as) = phi (go <$> as)+  go (Plus as) = psi (go <$> as)+{-# INLINE iter #-}++-- | 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 f = go where+  go (Pure a)  = Pure a+  go (Free as) = Free (go <$> f as)+  go (Plus as) = Plus (map go as)++#ifdef GHC_TYPEABLE+instance Typeable1 f => Typeable1 (Free f) where+  typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where+    f :: Free f a -> f a+    f = undefined++freeTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+freeTyCon = mkTyCon "Control.MonadPlus.Free.Free"+#else+freeTyCon = mkTyCon3 "free" "Control.MonadPlus.Free" "Free"+#endif+{-# NOINLINE freeTyCon #-}++instance+  ( Typeable1 f, Typeable a+  , Data a, Data (f (Free f a))+  ) => Data (Free f a) where+    gfoldl f z (Pure a) = z Pure `f` a+    gfoldl f z (Free as) = z Free `f` as+    gfoldl f z (Plus as) = z Plus `f` as+    toConstr Pure{} = pureConstr+    toConstr Free{} = freeConstr+    toConstr Plus{} = plusConstr+    gunfold k z c = case constrIndex c of+        1 -> k (z Pure)+        2 -> k (z Free)+        3 -> k (z Plus)+        _ -> error "gunfold"+    dataTypeOf _ = freeDataType+    dataCast1 f = gcast1 f++pureConstr, freeConstr, plusConstr :: Constr+pureConstr = mkConstr freeDataType "Pure" [] Prefix+freeConstr = mkConstr freeDataType "Free" [] Prefix+plusConstr = mkConstr freeDataType "Plus" [] Prefix+{-# NOINLINE pureConstr #-}+{-# NOINLINE freeConstr #-}++freeDataType :: DataType+freeDataType = mkDataType "Control.MonadPlus.Free.Free" [pureConstr, freeConstr, plusConstr]+{-# NOINLINE freeDataType #-}++#endif