free 4.11 → 4.12

raw patch · 11 files changed

+267/−31 lines, 11 filesdep +exceptionsdep ~basedep ~bifunctorsdep ~profunctorsPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependency ranges changed: base, bifunctors, profunctors, semigroupoids

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +5/−0
• free.cabal +9/−6
• src/Control/Alternative/Free.hs +6/−0
• src/Control/Alternative/Free/Final.hs +65/−0
• src/Control/Applicative/Free/Final.hs +84/−0
• src/Control/Applicative/Trans/Free.hs +9/−0
• src/Control/Comonad/Cofree.hs +6/−1
• src/Control/Monad/Free.hs +12/−1
• src/Control/Monad/Trans/Free.hs +17/−1
• src/Control/Monad/Trans/Free/Church.hs +45/−22
• src/Control/Monad/Trans/Iter.hs +9/−0

@@ -1,3 +1,8 @@+4.12+----+* Add instances of `MonadCatch` and `MonadThrow` from `exceptions` to `FT`, `FreeT` and `IterT`.+* `semigroupoids` 5, `profunctors` 5, and `bifunctors` 5 support.+ 4.11 ----- * Pass Monad[FreeT].fail into underlying monad

@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       4.11+version:       4.12 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -9,7 +9,7 @@ stability:     provisional homepage:      http://github.com/ekmett/free/ bug-reports:   http://github.com/ekmett/free/issues-copyright:     Copyright (C) 2008-2013 Edward A. Kmett+copyright:     Copyright (C) 2008-2015 Edward A. Kmett synopsis:      Monads for free description:   Free monads are useful for many tree-like structures and domain specific languages.@@ -67,21 +67,24 @@    build-depends:     base                 == 4.*,-    bifunctors           == 4.*,+    bifunctors           >= 4 && < 6,     comonad              == 4.*,     distributive         >= 0.2.1,     mtl                  >= 2.0.1.0 && < 2.3,     prelude-extras       >= 0.4 && < 1,-    profunctors          == 4.*,-    semigroupoids        == 4.*,+    profunctors          >= 4 && < 6,+    semigroupoids        >= 4 && < 6,     semigroups           >= 0.8.3.1 && < 1,     transformers         >= 0.2.0   && < 0.5,-    template-haskell     >= 2.7.0.0 && < 3+    template-haskell     >= 2.7.0.0 && < 3,+    exceptions           >= 0.6 && < 0.9    exposed-modules:     Control.Applicative.Free+    Control.Applicative.Free.Final     Control.Applicative.Trans.Free     Control.Alternative.Free+    Control.Alternative.Free.Final     Control.Comonad.Cofree     Control.Comonad.Cofree.Class     Control.Comonad.Trans.Cofree

@@ -29,6 +29,8 @@  import Control.Applicative import Data.Functor.Apply+import Data.Functor.Alt ((<!>))+import qualified Data.Functor.Alt as Alt import Data.Semigroup import Data.Typeable @@ -97,6 +99,10 @@ instance (Functor f) => Apply (Alt f) where   (<.>) = (<*>)   {-# INLINE (<.>) #-}++instance (Functor f) => Alt.Alt (Alt f) where+  (<!>) = (<|>)+  {-# INLINE (<!>) #-}  instance (Functor f) => Alternative (Alt f) where   empty = Alt []

@@ -0,0 +1,65 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Alternative.Free.Final+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- Final encoding of free 'Alternative' functors.+----------------------------------------------------------------------------+module Control.Alternative.Free.Final+  ( Alt(..)+  , runAlt+  , liftAlt+  , hoistAlt+  ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Functor.Alt ((<!>))+import qualified Data.Functor.Alt as Alt+import Data.Semigroup++-- | The free 'Alternative' for a 'Functor' @f@.+newtype Alt f a = Alt { _runAlt :: forall g. Alternative g => (forall x. f x -> g x) -> g a }++instance Functor (Alt f) where+  fmap f (Alt g) = Alt (\k -> fmap f (g k))++instance Apply (Alt f) where+  Alt f <.> Alt x = Alt (\k -> f k <*> x k)++instance Applicative (Alt f) where+  pure x = Alt (\_ -> pure x)+  Alt f <*> Alt x = Alt (\k -> f k <*> x k)++instance Alt.Alt (Alt f) where+  Alt x <!> Alt y = Alt (\k -> x k <|> y k)++instance Alternative (Alt f) where+  empty = Alt (\_ -> empty)+  Alt x <|> Alt y = Alt (\k -> x k <|> y k)++instance Semigroup (Alt f a) where+  (<>) = (<|>)++instance Monoid (Alt f a) where+  mempty = empty+  mappend = (<|>)++-- | A version of 'lift' that can be used with @f@.+liftAlt :: f a -> Alt f a+liftAlt f = Alt (\k -> k f)++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.+runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a+runAlt phi g = _runAlt g phi++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@.+hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b+hoistAlt phi (Alt g) = Alt (\k -> g (k . phi))+

@@ -0,0 +1,84 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative.Free.Final+-- Copyright   :  (C) 2012-2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- Final encoding of free 'Applicative' functors.+----------------------------------------------------------------------------+module Control.Applicative.Free.Final+  (+  -- | Compared to the free monad, they are less expressive. However, they are also more+  -- flexible to inspect and interpret, as the number of ways in which+  -- the values can be nested is more limited.++    Ap(..)+  , runAp+  , runAp_+  , liftAp+  , hoistAp+  , retractAp++  -- * Examples+  -- $examples+  ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Monoid++-- | The free 'Applicative' for a 'Functor' @f@.+newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a }++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp phi m = _runAp m phi++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)++instance Functor (Ap f) where+  fmap f (Ap g) = Ap (\k -> fmap f (g k))++instance Apply (Ap f) where+  Ap f <.> Ap x = Ap (\k -> f k <*> x k)++instance Applicative (Ap f) where+  pure x = Ap (\_ -> pure x)+  Ap f <*> Ap x = Ap (\k -> f k <*> x k)++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAp :: f a -> Ap f a+liftAp x = Ap (\k -> k x)++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b+hoistAp f (Ap g) = Ap (\k -> g (k . f))++-- | Interprets the free applicative functor over f using the semantics for+--   `pure` and `<*>` given by the Applicative instance for f.+--+--   prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp (Ap g) = g id++{- $examples++<examples/ValidationForm.hs Validation form>++-}

@@ -36,6 +36,7 @@   , hoistApF   , transApT   , transApF+  , joinApT   -- * Free Applicative   , Ap   , runAp@@ -47,6 +48,7 @@   ) where  import Control.Applicative+import Control.Monad (liftM) import Data.Functor.Apply import Data.Functor.Identity import Data.Typeable@@ -157,6 +159,13 @@ -- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@. transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b transApT f (ApT g) = ApT $ f (transApF f <$> g)++-- | Pull out and join @m@ layers of @'ApT' f m a@.+joinApT :: Monad m => ApT f m a -> m (Ap f a)+joinApT (ApT m) = m >>= joinApF+  where+    joinApF (Pure x) = return (pure x)+    joinApF (Ap x y) = (liftApT x <**>) `liftM` joinApT y  -- | The free 'Applicative' for a 'Functor' @f@. type Ap f = ApT f Identity

@@ -26,6 +26,7 @@   , section   , coiter   , unfold+  , unfoldM   , hoistCofree   -- * Lenses into cofree comonads   , _extract@@ -41,7 +42,7 @@ import Control.Comonad.Store.Class as Class import Control.Comonad.Traced.Class import Control.Category-import Control.Monad(ap)+import Control.Monad(ap, (>=>), liftM) import Control.Monad.Zip import Data.Functor.Bind import Data.Functor.Extend@@ -113,6 +114,10 @@ unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a unfold f c = case f c of   (x, d) -> x :< fmap (unfold f) d++-- | Unfold a cofree comonad from a seed, monadically.+unfoldM :: (Traversable f, Monad m) => (b -> m (a, f b)) -> b -> m (Cofree f a)+unfoldM f = f >=> \ (x, t) -> (x :<) `liftM` Data.Traversable.mapM (unfoldM f) t  hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y)

@@ -33,11 +33,14 @@   , foldFree   , toFreeT   , cutoff+  , unfold+  , unfoldM   , _Pure, _Free   ) where  import Control.Applicative-import Control.Monad (liftM, MonadPlus(..))+import Control.Arrow ((>>>))+import Control.Monad (liftM, MonadPlus(..), (>=>)) import Control.Monad.Fix import Control.Monad.Trans.Class import qualified Control.Monad.Trans.Free as FreeT@@ -338,6 +341,14 @@ cutoff n _ | n <= 0 = return Nothing cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f cutoff _ m = Just <$> m++-- | Unfold a free monad from a seed.+unfold :: Functor f => (b -> Either a (f b)) -> b -> Free f a+unfold f = f >>> either Pure (Free . fmap (unfold f))++-- | Unfold a free monad from a seed, monadically.+unfoldM :: (Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)+unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))  -- | This is @Prism' (Free f a) a@ in disguise --

@@ -39,6 +39,7 @@   , iterTM   , hoistFreeT   , transFreeT+  , joinFreeT   , cutoff   , partialIterT   , intersperseT@@ -54,6 +55,7 @@  import Control.Applicative import Control.Monad (liftM, MonadPlus(..), ap, join)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class import Control.Monad.Free.Class import Control.Monad.IO.Class@@ -286,6 +288,14 @@   wrap = FreeT . return . Free   {-# INLINE wrap #-} +instance (Functor f, MonadThrow m) => MonadThrow (FreeT f m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance (Functor f, MonadCatch m) => MonadCatch (FreeT f m) where+  FreeT m `catch` f = FreeT $ liftM (fmap (`catch` f)) m `catch` (runFreeT . f)+  {-# INLINE catch #-}+ -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a iterT f (FreeT m) = do@@ -318,6 +328,13 @@ transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT +-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a)+joinFreeT (FreeT m) = m >>= joinFreeF+  where+    joinFreeF (Pure x) = return (return x)+    joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f+ -- | -- 'retract' is the left inverse of 'liftF' --@@ -479,4 +496,3 @@ {-# NOINLINE freeFDataType #-} {-# NOINLINE freeTDataType #-} #endif-

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-}  #ifndef MIN_VERSION_mtl@@ -17,7 +17,7 @@ -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  provisional -- Portability :  non-portable (rank-2 polymorphism, MTPCs)--- +-- -- Church-encoded free monad transformer. -- -----------------------------------------------------------------------------@@ -28,11 +28,13 @@   -- * The free monad   , F, free, runF   -- * Operations+  , improveT   , toFT, fromFT   , iterT   , iterTM   , hoistFT   , transFT+  , joinFT   , cutoff   -- * Operations of free monad   , improve@@ -49,6 +51,7 @@ import Control.Applicative import Control.Category ((<<<), (>>>)) import Control.Monad+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Identity import Control.Monad.Trans.Class import Control.Monad.IO.Class@@ -68,7 +71,7 @@ import Data.Function  -- | The \"free monad transformer\" for a functor @f@-newtype FT f m a = FT {runFT :: forall r. (a -> m r) -> (f (m r) -> m r) -> m r}+newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r }  instance (Functor f, Monad m, Eq (FreeT f m a)) => Eq (FT f m a) where   (==) = (==) `on` fromFT@@ -93,8 +96,8 @@   return = pure   FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr -instance (Functor f) => MonadFree f (FT f m) where-  wrap f = FT (\kp kf -> kf (fmap (\(FT m) -> m kp kf) f))+instance MonadFree f (FT f m) where+  wrap f = FT (\kp kf -> kf (\ft -> runFT ft kp kf) f)  instance MonadTrans (FT f) where   lift m = FT (\a _ -> m >>= a)@@ -110,14 +113,14 @@ instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where   foldr f r xs = F.foldr (<<<) id inner r     where-      inner = runFT xs (return . f) (F.foldr (liftM2 (<<<)) (return id))+      inner = runFT xs (return . f) (\xg xf -> F.foldr (liftM2 (<<<) . xg) (return id) xf)   {-# INLINE foldr #-}  #if MIN_VERSION_base(4,6,0)   foldl' f z xs = F.foldl' (!>>>) id inner z     where       (!>>>) h g = \r -> g $! h r-      inner = runFT xs (return . flip f) (F.foldr (liftM2 (>>>)) (return id))+      inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf)   {-# INLINE foldl' #-} #endif @@ -125,7 +128,7 @@   traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree     where       traversePure = return . fmap return . f-      traverseFree = return . fmap (wrap . fmap (join . lift)) . T.sequenceA . fmap T.sequenceA+      traverseFree xg = return . fmap (wrap . fmap (join . lift)) . T.traverse (T.sequenceA . xg)  instance (MonadIO m) => MonadIO (FT f m) where   liftIO = lift . liftIO@@ -165,49 +168,61 @@   {-# INLINE state #-} #endif +instance MonadThrow m => MonadThrow (FT f m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where+  catch m f = toFT $ fromFT m `catch` (fromFT . f)+  {-# INLINE catch #-}+ -- | Generate a Church-encoded free monad transformer from a 'FreeT' monad -- transformer.-toFT :: (Monad m, Functor f) => FreeT f m a -> FT f m a+toFT :: Monad m => FreeT f m a -> FT f m a toFT (FreeT f) = FT $ \ka kfr -> do   freef <- f   case freef of     Pure a -> ka a-    Free fb -> kfr $ fmap (($ kfr) . ($ ka) . runFT . toFT) fb+    Free fb -> kfr (\x -> runFT (toFT x) ka kfr) fb  -- | Convert to a 'FreeT' free monad representation. fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a-fromFT (FT k) = FreeT $ k (return . Pure) (runFreeT . wrap . fmap FreeT)+fromFT (FT k) = FreeT $ k (return . Pure) (\xg -> runFreeT . wrap . fmap (FreeT . xg))  -- | The \"free monad\" for a functor @f@. type F f = FT f Identity  -- | Unwrap the 'Free' monad to obtain it's Church-encoded representation. runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r)-runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (return . kf . fmap runIdentity)+runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (\xg -> return . kf . fmap (runIdentity . xg))  -- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor.-free :: Functor f => (forall r. (a -> r) -> (f r -> r) -> r) -> F f a-free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf . fmap return))+free :: (forall r. (a -> r) -> (f r -> r) -> r) -> F f a+free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf return))  -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a-iterT phi (FT m) = m return phi+iterT phi (FT m) = m return (\xg -> phi . fmap xg) {-# INLINE iterT #-}  -- | Tear down a free monad transformer using iteration over a transformer. iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FT f m a -> t m a-iterTM f (FT m) = join . lift $ m (return . return) (return . f . fmap (join .lift))+iterTM f (FT m) = join . lift $ m (return . return) (\xg -> return . f . fmap (join . lift . xg))  -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FT' f m@ to @'FT' f n@ -- -- @'hoistFT' :: ('Monad' m, 'Monad' n, 'Functor' f) => (m ~> n) -> 'FT' f m ~> 'FT' f n@-hoistFT :: (Monad m, Monad n, Functor f) => (forall a. m a -> n a) -> FT f m b -> FT f n b-hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (return . kf . fmap (join . phi)))+hoistFT :: (Monad m, Monad n) => (forall a. m a -> n a) -> FT f m b -> FT f n b+hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (\xg -> return . kf (join . phi . xg)))  -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@-transFT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FT f m b -> FT g m b-transFT phi (FT m) = FT (\kp kf -> m kp (kf . phi))+transFT :: Monad m => (forall a. f a -> g a) -> FT f m b -> FT g m b+transFT phi (FT m) = FT (\kp kf -> m kp (\xg -> kf xg . phi)) +-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFT :: (Monad m, Traversable f) => FT f m a -> m (F f a)+joinFT (FT m) = m (return . return) (\xg -> liftM wrap . T.mapM xg)+ -- | Cuts off a tree of computations at a given depth. -- If the depth is 0 or less, no computation nor -- monadic effects will take place.@@ -236,7 +251,7 @@  -- | Tear down a free monad transformer using iteration over a transformer. retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a-retractT (FT m) = join . lift $ m (return . return) $ \x -> return $ x >>= join . lift+retractT (FT m) = join . lift $ m (return . return) (\xg xf -> return $ xf >>= join . lift . xg)  -- | Tear down an 'F' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> F f a -> a@@ -253,7 +268,7 @@ {-# INLINE fromF #-}  -- | Generate a Church-encoded free monad from a 'Free' monad.-toF :: (Functor f) => Free f a -> F f a+toF :: Free f a -> F f a toF = toFT {-# INLINE toF #-} @@ -270,4 +285,12 @@ improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = fromF m {-# INLINE improve #-}++-- | Improve the asymptotic performance of code that builds a free monad transformer+-- with only binds and returns by using 'FT' behind the scenes.+--+-- Similar to 'improve'.+improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a+improveT m = fromFT m+{-# INLINE improveT #-} 

@@ -73,6 +73,7 @@   ) where  import Control.Applicative+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad (ap, liftM, MonadPlus(..), join) import Control.Monad.Fix import Control.Monad.Trans.Class@@ -268,6 +269,14 @@ instance Monad m => MonadFree Identity (IterT m) where   wrap = IterT . return . Right . runIdentity   {-# INLINE wrap #-}++instance MonadThrow m => MonadThrow (IterT m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (IterT m) where+  catch (IterT m) f = IterT $ liftM (fmap (`catch` f)) m `catch` (runIterT . f)+  {-# INLINE catch #-}  -- | Adds an extra layer to a free monad value. --