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 - [email protected] + +- 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 <[email protected]> +-- 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 <[email protected]> +-- 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 + +<examples/ValidationForm.hs Validation form> + +-} 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 <[email protected]> -- 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
