Hello community,
here is the log from the commit of package ghc-free for openSUSE:Factory checked in at 2015-08-27 08:55:29
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-free (Old)
and /work/SRC/openSUSE:Factory/.ghc-free.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-free"
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-free/ghc-free.changes 2015-05-22 09:50:40.000000000 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-free.new/ghc-free.changes 2015-08-27 08:55:30.000000000 +0200
@@ -1,0 +2,7 @@
+Thu Aug 6 19:27:49 UTC 2015 - mimi.vx@gmail.com
+
+- update to 4.12.1
+* Add instances of MonadCatch and MonadThrow from exceptions to FT, FreeT and IterT.
+* semigroupoids 5, profunctors 5, and bifunctors 5 support.
+
+-------------------------------------------------------------------
Old:
----
free-4.11.tar.gz
New:
----
free-4.12.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-free.spec ++++++
--- /var/tmp/diff_new_pack.RQQegC/_old 2015-08-27 08:55:30.000000000 +0200
+++ /var/tmp/diff_new_pack.RQQegC/_new 2015-08-27 08:55:30.000000000 +0200
@@ -17,8 +17,8 @@
%global pkg_name free
-Name: ghc-%{pkg_name}
-Version: 4.11
+Name: ghc-free
+Version: 4.12.1
Release: 0
Summary: Monads for free
Group: System/Libraries
@@ -34,6 +34,7 @@
BuildRequires: ghc-bifunctors-devel
BuildRequires: ghc-comonad-devel
BuildRequires: ghc-distributive-devel
+BuildRequires: ghc-exceptions-devel
BuildRequires: ghc-mtl-devel
BuildRequires: ghc-prelude-extras-devel
BuildRequires: ghc-profunctors-devel
++++++ free-4.11.tar.gz -> free-4.12.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/.travis.yml new/free-4.12.1/.travis.yml
--- old/free-4.11/.travis.yml 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/.travis.yml 2015-05-15 19:34:34.000000000 +0200
@@ -1,8 +1,42 @@
-language: haskell
+env:
+ - GHCVER=7.4.2 CABALVER=1.16
+ - GHCVER=7.6.3 CABALVER=1.16
+ - GHCVER=7.8.4 CABALVER=1.18
+ - GHCVER=7.10.1 CABALVER=1.22
+ - GHCVER=head CABALVER=1.22
+
+matrix:
+ allow_failures:
+ - env: GHCVER=head CABALVER=1.22
+
+before_install:
+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+ - travis_retry sudo apt-get update
+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+ - cabal --version
+
+install:
+ - travis_retry cabal update
+ - cabal install --enable-tests --only-dependencies
+
+script:
+ - cabal configure -v2 --enable-tests
+ - cabal build
+ - cabal sdist
+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
+ cd dist/;
+ if [ -f "$SRC_TGZ" ]; then
+ cabal install "$SRC_TGZ";
+ else
+ echo "expected '$SRC_TGZ' not found";
+ exit 1;
+ fi
+
notifications:
irc:
channels:
- "irc.freenode.org#haskell-lens"
skip_join: true
template:
- - "\x0313free\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+ - "\x0313free\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/CHANGELOG.markdown new/free-4.12.1/CHANGELOG.markdown
--- old/free-4.11/CHANGELOG.markdown 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/CHANGELOG.markdown 2015-05-15 19:34:34.000000000 +0200
@@ -1,3 +1,12 @@
+4.12.1
+------
+* Support GHC 7.4
+
+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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/free.cabal new/free-4.12.1/free.cabal
--- old/free-4.11/free.cabal 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/free.cabal 2015-05-15 19:34:34.000000000 +0200
@@ -1,6 +1,6 @@
name: free
category: Control, Monads
-version: 4.11
+version: 4.12.1
license: BSD3
cabal-version: >= 1.10
license-file: LICENSE
@@ -9,7 +9,8 @@
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
+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1
synopsis: Monads for free
description:
Free monads are useful for many tree-like structures and domain specific languages.
@@ -67,21 +68,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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Alternative/Free/Final.hs new/free-4.12.1/src/Control/Alternative/Free/Final.hs
--- old/free-4.11/src/Control/Alternative/Free/Final.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/free-4.12.1/src/Control/Alternative/Free/Final.hs 2015-05-15 19:34:34.000000000 +0200
@@ -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
+-- 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))
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Alternative/Free.hs new/free-4.12.1/src/Control/Alternative/Free.hs
--- old/free-4.11/src/Control/Alternative/Free.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Alternative/Free.hs 2015-05-15 19:34:34.000000000 +0200
@@ -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
@@ -98,6 +100,10 @@
(<.>) = (<*>)
{-# INLINE (<.>) #-}
+instance (Functor f) => Alt.Alt (Alt f) where
+ () = (<|>)
+ {-# INLINE () #-}
+
instance (Functor f) => Alternative (Alt f) where
empty = Alt []
{-# INLINE empty #-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Applicative/Free/Final.hs new/free-4.12.1/src/Control/Applicative/Free/Final.hs
--- old/free-4.11/src/Control/Applicative/Free/Final.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/free-4.12.1/src/Control/Applicative/Free/Final.hs 2015-05-15 19:34:34.000000000 +0200
@@ -0,0 +1,92 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Applicative.Free.Final
+-- Copyright : (C) 2012-2013 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Edward Kmett
+-- 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
+
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Monoid
+#endif
+
+-- | 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
+
+
+
+-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Applicative/Free.hs new/free-4.12.1/src/Control/Applicative/Free.hs
--- old/free-4.11/src/Control/Applicative/Free.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Applicative/Free.hs 2015-05-15 19:34:34.000000000 +0200
@@ -5,6 +5,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
#endif
{-# OPTIONS_GHC -Wall #-}
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Applicative.Free
@@ -40,7 +44,10 @@
import Control.Applicative
import Data.Functor.Apply
import Data.Typeable
+
+#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
+#endif
-- | The free 'Applicative' for a 'Functor' @f@.
data Ap f a where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Applicative/Trans/Free.hs new/free-4.12.1/src/Control/Applicative/Trans/Free.hs
--- old/free-4.11/src/Control/Applicative/Trans/Free.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Applicative/Trans/Free.hs 2015-05-15 19:34:34.000000000 +0200
@@ -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
@@ -158,6 +160,13 @@
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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Comonad/Cofree.hs new/free-4.12.1/src/Control/Comonad/Cofree.hs
--- old/free-4.11/src/Control/Comonad/Cofree.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Comonad/Cofree.hs 2015-05-15 19:34:34.000000000 +0200
@@ -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
@@ -114,6 +115,10 @@
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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Free/Class.hs new/free-4.12.1/src/Control/Monad/Free/Class.hs
--- old/free-4.11/src/Control/Monad/Free/Class.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Free/Class.hs 2015-05-15 19:34:34.000000000 +0200
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -7,6 +8,10 @@
{-# LANGUAGE TypeFamilies #-}
#endif
{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Free.Class
@@ -25,7 +30,6 @@
, wrapT
) where
-import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
@@ -40,8 +44,11 @@
import Control.Monad.Trans.List
import Control.Monad.Trans.Error
import Control.Monad.Trans.Identity
--- import Control.Monad.Trans.Either
+
+#if !(MIN_VERSION_base(4,8,0))
+import Control.Applicative
import Data.Monoid
+#endif
-- |
-- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'):
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Free/TH.hs new/free-4.12.1/src/Control/Monad/Free/TH.hs
--- old/free-4.11/src/Control/Monad/Free/TH.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Free/TH.hs 2015-05-15 19:34:34.000000000 +0200
@@ -1,3 +1,9 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Trans.TH
@@ -27,11 +33,14 @@
) where
import Control.Arrow
-import Control.Applicative
import Control.Monad
import Data.Char (toLower)
import Language.Haskell.TH
+#if !(MIN_VERSION_base(4,8,0))
+import Control.Applicative
+#endif
+
data Arg
= Captured Type Exp
| Param Type
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Free.hs new/free-4.12.1/src/Control/Monad/Free.hs
--- old/free-4.11/src/Control/Monad/Free.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Free.hs 2015-05-15 19:34:34.000000000 +0200
@@ -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
@@ -339,6 +342,14 @@
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
--
-- >>> preview _Pure (Pure 3)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Trans/Free/Church.hs new/free-4.12.1/src/Control/Monad/Trans/Free/Church.hs
--- old/free-4.11/src/Control/Monad/Trans/Free/Church.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Trans/Free/Church.hs 2015-05-15 19:34:34.000000000 +0200
@@ -1,9 +1,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
@@ -17,7 +21,7 @@
-- Maintainer : Edward Kmett
-- Stability : provisional
-- Portability : non-portable (rank-2 polymorphism, MTPCs)
---
+--
-- Church-encoded free monad transformer.
--
-----------------------------------------------------------------------------
@@ -28,11 +32,13 @@
-- * The free monad
, F, free, runF
-- * Operations
+ , improveT
, toFT, fromFT
, iterT
, iterTM
, hoistFT
, transFT
+ , joinFT
, cutoff
-- * Operations of free monad
, improve
@@ -49,6 +55,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
@@ -60,15 +67,18 @@
import Control.Monad.Free.Class
import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free)
import qualified Control.Monad.Trans.Free as FreeT
-import Data.Foldable (Foldable)
import qualified Data.Foldable as F
-import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Functor.Bind hiding (join)
import Data.Function
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Foldable (Foldable)
+import Data.Traversable (Traversable)
+#endif
+
-- | 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 +103,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 +120,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 +135,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,48 +175,60 @@
{-# 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 `Control.Monad.Catch.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
@@ -236,7 +258,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 +275,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 #-}
@@ -271,3 +293,11 @@
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 #-}
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Trans/Free.hs new/free-4.12.1/src/Control/Monad/Trans/Free.hs
--- old/free-4.11/src/Control/Monad/Trans/Free.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Trans/Free.hs 2015-05-15 19:34:34.000000000 +0200
@@ -9,6 +9,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
#endif
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
@@ -39,6 +43,7 @@
, iterTM
, hoistFreeT
, transFreeT
+ , joinFreeT
, cutoff
, partialIterT
, intersperseT
@@ -54,6 +59,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
@@ -64,7 +70,6 @@
import Control.Monad.Cont.Class
import Data.Functor.Bind hiding (join)
import Data.Monoid
-import Data.Foldable
import Data.Function (on)
import Data.Functor.Identity
import Data.Traversable
@@ -74,6 +79,10 @@
import Data.Data
import Prelude.Extras
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Foldable
+#endif
+
-- | The base functor for a free monad.
data FreeF f a b = Pure a | Free (f b)
deriving (Eq,Ord,Show,Read
@@ -286,6 +295,15 @@
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 (`Control.Monad.Catch.catch` f)) m
+ `Control.Monad.Catch.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 +336,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 +504,3 @@
{-# NOINLINE freeFDataType #-}
{-# NOINLINE freeTDataType #-}
#endif
-
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/free-4.11/src/Control/Monad/Trans/Iter.hs new/free-4.12.1/src/Control/Monad/Trans/Iter.hs
--- old/free-4.11/src/Control/Monad/Trans/Iter.hs 2015-03-07 06:01:47.000000000 +0100
+++ new/free-4.12.1/src/Control/Monad/Trans/Iter.hs 2015-05-15 19:34:34.000000000 +0200
@@ -6,6 +6,10 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveDataTypeable #-}
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
@@ -73,6 +77,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
@@ -88,9 +93,7 @@
import Data.Either
import Data.Functor.Bind hiding (join)
import Data.Functor.Identity
-import Data.Foldable hiding (fold)
import Data.Function (on)
-import Data.Traversable hiding (mapM)
import Data.Monoid
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
@@ -98,6 +101,11 @@
import Data.Data
import Prelude.Extras
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Foldable hiding (fold)
+import Data.Traversable hiding (mapM)
+#endif
+
-- | The monad supporting iteration based over a base monad @m@.
--
-- @
@@ -269,6 +277,14 @@
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 (`Control.Monad.Catch.catch` f)) m `Control.Monad.Catch.catch` (runIterT . f)
+ {-# INLINE catch #-}
+
-- | Adds an extra layer to a free monad value.
--
-- In particular, for the iterative monad 'Iter', this makes the
