diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist +dist-newstyle docs wiki TAGS @@ -11,3 +12,21 @@ *.hi *~ *# +.cabal-sandbox/ +cabal.sandbox.config +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,15 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi, --cpp-include=include] + +- fixity: "infixr 5 :<" + +# This affects performance +- ignore: {name: Redundant lambda} + +# This is not valid for improve +- ignore: {name: Eta reduce} + +# DeriveDataTypable noise +- ignore: {name: Unused LANGUAGE pragma} + +# They are clearer in places +- ignore: {name: Avoid lambda} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,8 +0,0 @@ -language: haskell -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313free\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,215 @@ +5.2 [2023.03.12] +---------------- +* Drop support for GHC 7.10 and earlier. +* Drop redundant `Monad` constraints on many functions and instances. These + constraints were only present for compatibility with pre-7.10 versions of + GHC, which `free` no longer supports. +* Add `Eq`, `Eq1`, `Ord`, `Ord1`, and `Foldable` instances for `Ap` in + `Control.Applicative.Free`. +* Switch out `bifunctors` dependency for `bifunctor-classes-compat`. + +5.1.10 [2022.11.30] +------------------- +* Add a `MonadFail` instance for `FT`. + +5.1.9 [2022.06.26] +------------------ +* Simplify the `Eq` and `Ord` instances for `FT` to avoid the use of + overlapping instances. + +5.1.8 [2022.05.07] +------------------ +* Generalize the `Monad` constraint in the type signatures for + `hoistFreeT` in `Control.Monad.Trans.Free` and `Control.Monad.Trans.Free.Ap` + to a `Functor` constraint. +* Allow building with `transformers-0.6.*` and `mtl-2.3.*`. + +5.1.7 [2021.04.30] +------------------ +* Enable `FlexibleContexts` in `Control.Monad.Trans.Free.Church` to allow + building with GHC 9.2. + +5.1.6 [2020.12.31] +------------------ +* Explicitly mark modules as `Safe`. + +5.1.5 [2020.12.16] +------------------ +* Move `indexed-traversable` (`FunctorWithIndex` etc) instances from `lens`. + +5.1.4 [2020.10.01] +------------------ +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). + +5.1.3 [2019.11.26] +------------------ +* Allow building with `template-haskell-2.16` (GHC 8.10). +* Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for + `CofreeF`. + +5.1.2 [2019.08.27] +------------------ +* Implement more performant versions of `some` and `many` in the `Alternative` + instance for the final `Alt` encoding. + +5.1.1 [2019.05.02] +------------------ +* Allow building with `base-4.13` (GHC 8.8). + +5.1 [2018.07.03] +---------------- +* Generalize the type of `_Free`. +* Allow building with `containers-0.6`. +* Avoid incurring some dependencies when using recent GHCs. + +5.0.2 [2018.04.25] +------------------ +* Add `Generic` and `Generic1` instances where possible. + +5.0.1 [2018.03.07] +------------------ +* Fix the build on old GHCs with `transformers-0.4`. + +5 [2018.01.28] +-------------- +* Add a `Semigroup` instance for `IterT`. +* Add `MonadFail` instances for `IterT` and `FreeT`. +* Add a `Comonad` instance for the free `Applicative`, `Ap`. +* Add `Control.Monad.Free.Ap` and `Control.Monad.Trans.Free.Ap` modules, based + on the "Applicative Effects in Free Monads" series of articles by Will + Fancher. +* Derive `Data` instances for `Free` and `Cofree`. +* `Control.Monad.Free.TH` now properly supports `template-haskell-2.11.0.0`. In + particular, it now supports `GadtC` and `RecGadtC`, which are new + `template-haskell` forms for representing GADTs. +* Add `telescoped_`, `shoots`, and `leaves` to `Control.Comonad.Cofree` +* Add the `Control.Applicative.Free.Fast` module, based on Dave Menendez's + article "Free Applicative Functors in Haskell" +* Add `foldFreeT` to `Control.Monad.Trans.Free` +* Improve the `foldMap` and `cutoff` functions for + `Control.Monad.Free.Church.F`, and add a `Traversable` +* Add a `MonadBase` instance for `FreeT` +* Add a performance test comparing Free and Church interpreters +* The use of `prelude-extras` has been removed. `free` now uses the + `Data.Functor.Classes` module to give `free`'s datatypes instances of `Eq1`, + `Ord1`, `Read1`, and `Show1`. Their `Eq`, `Ord`, `Read`, and `Show` instances + have also been modified to incorporate these classes. For example, what + previously existed as: + + ```haskell + instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where + ``` + + has now been changed to: + + ```haskell + instance (Eq1 f, Eq a) => Eq (Free f a) where + ``` +* Remove redundant `Functor` constraints from `Control.Alternative.Free` + +4.12.4 +------ +* Removed a number of spurious class constraints. +* Support GHC 8 + +4.12.3 +------ +* Support `comonad` 5 + +4.12.2 +------ +* Add instances for `ExceptT`: like `ErrorT`, but without an `Error` constraint. +* Support `containers` +* Support `transformers` 0.5 + + +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 +* Add `retractT`. +* Added `cutoff` for the church encoded free monad. +* `cutoff` now accepts negative numbers. +* Added `intersperseT` and `intercalateT`. +* Added `foldFree` and `foldF`. +* Added some new `template-haskell` toys. + +4.10.0.1 +------ +* Fix for very old `cabal` versions where the `MIN_VERSION_foo` macros aren't negation friendly. + +4.10 +---- +* Redefine `Alternative` and `MonadPlus` instances of `IterT` so that they apply to any underlying `Monad`. + `mplus` or `<|>` is Capretta's `race` combinator; `mzero` or `empty` is a non-terminating computation. +* Redefine `fail s` for `IterT` as `mzero`, for any string `s`. +* Added `Control.Monad.Trans.Iter.untilJust`, which repeatedly retries a `m (Maybe a)` computation until + it produces `Just` a value. +* Fix things so that we can build with GHC 7.10, which also uses the name `Alt` in `Data.Monoid`, and which exports `Monoid` from `Prelude`. + +4.9 +--- +* Remove `either` support. Why? It dragged in a large number of dependencies we otherwise don't support, and so is probably best inverted. + +4.8.0.1 +------- +* Allow complation with older versions of `base`. (Foldable didn't add foldl' until base 4.6) + +4.8 +----- +* Added a `MonadFree` instance for `EitherT` (frrom the `either` package). +* Support for `transformers` 0.4 + +4.7.1 +----- +* Added more versions of `cutoff`. + +4.7 +--- +* Added `prelude-extras` support. This makes it possible to work without `UndecidableInstances` for most operations. +* Removed the `GHC_TYPEABLE` flag. + +4.6.1 +----- +* Added `hoistF` + +4.6 +--- +* Víctor López Juan and Fabian Ruch added many documentation improvements and a whole host of proofs of correctness. +* Improvements in the template haskell code generator. +* Added instances for `MonadWriter` and `MonadCont` where appropriate, thanks to Nickolay Kudasov. +* Added `cutoff`, `iterTM`, and `never`. +* Made modifications to some `Typeable` and `Data` instances to work correctly on both GHC 7.8.1rc1 and 7.8.1rc2. +* Removed `Control.MonadPlus.Free`. Use `FreeT f []` instead and the result will be law-abiding. +* Replaced `Control.Alternative.Free` with a new approach that is law-abiding for left-distributive Alternatives. + +4.5 +----- +* Added `Control.Monad.Free.TH` with `makeFree` to make it easier to write free monads. +* Added missing instances for `MonadFix` and `MonadCont` where appropriate. + +4.2 +----- +* Added `Control.Monad.Trans.Iter` and `Control.Comonad.Trans.Coiter`. + +4.1.1 +----- +* Added a default signature to `wrap`, based on a construction by @fizruk. + +4.0 +--- +* Updated to work with `semigroupoids` and `comonad` 4.0 +* `instance ComonadCofree Maybe NonEmpty` +* `instance ComonadCofree (Const b) ((,) b)` + 3.4.2 ----- * Generalized `liftF`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2008-2012 Edward Kmett +Copyright 2008-2013 Edward Kmett All rights reserved. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ free ==== -[![Build Status](https://secure.travis-ci.org/ekmett/free.png?branch=master)](http://travis-ci.org/ekmett/free) +[![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://github.com/ekmett/free/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/free/actions?query=workflow%3AHaskell-CI) This package provides a common definitions for working with free monads, free applicatives, and cofree comonads in Haskell. diff --git a/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md @@ -0,0 +1,6 @@ +Instance of Applicative for Cofree +================================== + +See [proof for the transformer version] +(../Trans/Cofree/instance-Applicative-CofreeT.md) and specialize it for the +Identity applicative functor. diff --git a/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md @@ -0,0 +1,6 @@ +Instance of Monad for Cofree +================================== + +See [proof for the transformer version] +(../Trans/Cofree/instance-Monad-CofreeT.md) and specialize it for the +Identity Monad. diff --git a/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md @@ -0,0 +1,9 @@ +MonadZip instance for Cofree +============================ + +For every functor `f` with `Alternative` and `MonadZip` instances, +`Cofree f` is an instance of `MonadZip`. + +The claim follows as a corollary from the [`MonadZip` instance theorem +for `CofreeT`](../Trans/Cofree/instance-MonadZip-CofreeT.md) when `m` is +set to be `Identity`, which obviously has an instance of `MonadZip`. diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md @@ -0,0 +1,612 @@ +Applicative instance for CofreeT +================================ + +If the underlying functor f is an instance of Alternative, then CofreeT is also +an applicative functor. + +Note that the only required properties of Alternative are associativity and +existence of an identity element, so one could also use functors that are +instances of Plus (semigroupoid package). + +```haskell +instance (Alternative f, Applicative w) => + Applicative (CofreeT f w) where + pure = CofreeT . pure . (:< empty) + + (CofreeT wf) <*> aa@(CofreeT wa) = CofreeT $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> aa) t)) <$> wf <*> wa +``` + + +## Identity + +```haskell + + pure id <*> (C wa) + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> C wa) t)) <$> (pure $ id :< empty) <*> wa + +== {- w is Applicative -} + + C $ + \(a) -> + let (b :< n) = bimap id (fmap id) a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- functor preserves identity -} + + C $ + \(a) -> + let (b :< n) = bimap id id a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- bifunctors preserve identity -} + + C $ + \(a) -> + let (b :< n) = a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- empty is invariant under fmap -} + + C $ + \(a) -> + let (b :< n) = a in + b :< (n <|> empty) <$> wa + +== {- empty is identity, β-reduction -} + + C $ id <$> wa + +== {- functor preserves identity -} + + C wa + +``` + + +## Composition + +First, we rewrite the definition of the (<*>) into something simpler: + +```haskell + + (C wf) <*> (C wa) + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- pattern match on CofreeF -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + let (b :< n) = bimap f (fmap f) (a :< m) in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- definition of bimap -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + let (b :< n) = f a :< fmap (fmap f) m in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- β-equivalence -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + (f a) :< (fmap (fmap f) m <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- define star(C wa) ≡ ( \(f :< t) -> … (<*> C wa) … ) -} + + C $ star(C wa) <$> wf <*> wa + +== {- fmap for w Applicative -} + + C (pure star(C wa) <*> wf <*> wa) + +``` + +Now, we can prove the law of composition: + +```haskell + + pure (.) <*> C u <*> C v <*> C w + +== {- definition of <*> -} + + C (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> C v <*> C w + +== {- definition of <*> -} + + C (pure star(C v) <*> + (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> + v + ) <*> + C w + +== {- definition of <*> -} + + C (pure star(C w) <*> + (pure star(C v) <*> + (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> + v) <*> + w) + + +== {- see lemma 1 -} + + C $ (\a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (\x -> pure (.) <*> pure a <*> x <*> C w) n) <|> + fmap (\x -> pure (.) <*> x <*> C v <*> C w) m))) == + + + + +== {- coinduction on recursive definition (“produce 1, consume 1”) -} + + + C $ (\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap (\x -> pure a <*> (x <*> C w)) n) <|> + (fmap (\x -> x<*> (C v <*> C w)) m) ) + + +== {- see lemma 2 -} + + C (pure star(C v <*> C w) <*> + u <*> + (pure star(C w) <*> + v <*> + w)) + +== {- definition of <*> -} + + C (pure star(C v <*> C w) <*> u <*> unC (C v <*> C w)) + +== {- definition of <*> -} + + C u <*> (C v <*> C w) +``` + +### Lemma 1 + +To make reasoning easier, we'll use a shortand notation. + +``` +U ≡ star(C v) +V ≡ star(C u) +W ≡ star(C w) +! ≡ (.) :< empty +p ≡ pure + ≡ function application +. ≡ (.) +``` + +By repeatedly applying the Applicative laws for the underlying functor, we +get: + +```haskell + +pW <*> (pV <*> (pU <*> p! <*> u) <*> v ) <*> w == + +pW <*> (pV <*> (p(U!) <*> u) <*> v ) <*> w == + +pW <*> (p. <*> pV <*> p(U!) <*> u <*> v ) <*> w == + +pW <*> ( p(.V)(U!) <*> u <*> v ) <*> w == + +p. <*> pW <*> ( p(.V)(U!) <*> u ) <*> v <*> w == + +p(.W) <*> (p(.V)(U!) <*> u) <*> v <*> w == + +p. <*> p(.W) <*> p(.V)(U!) <*> u <*> v <*> w == + +p.(.W)((.V)(U!)) <*> u <*> v <*> w + +``` + +Undoing the shorthand notation and simplifying: + +```haskell + +! == (.) :< empty +U! == \(a :< m) -> (. a) :< fmap (fmap (.)) m +V == \(f :< t) -> \(b :< n) -> (f b) :< (fmap (fmap f) n <|> + fmap (<*> C v) t) + + +. V (U!) == \(a :< m) -> V ((. a) :< fmap (fmap (.)) m) == + == \(a :< m) -> \(b :< n) -> + (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m) + +W == \(f :< t) -> \(c :< p) -> + (f c) :< (fmap (fmap f) p <|> fmap (<*> C w) t) + +.W == \g -> (\x -> W (g x)) + + + .(.W)(.V(U!)) + +== \s -> (.W)((.V(U!)) s) == + +== \a :< m -> (.W) ((.V(U!)) a :< m) == + +== \a :< m -> (.W) (\(b :< n) -> + (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> + W ( (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (<*> C w) + ((fmap (fmap (. a) n) <|> + fmap (<*> C v) (fmap (fmap (.)) m)))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (<*> C w) (fmap (fmap (. a)) n) <|> + fmap (<*> C w) (fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (\x -> pure (.) <*> pure a <*> x <*> C w) n) <|> + fmap (\x -> pure (.) <*> x <*> C v <*> C w) m))) +``` + +### Lemma 2 + +We use the following shorthands to make reasoning more readable. + +``` +W ≡ star(C w) +Y ≡ star(C v <*> C w) +p ≡ pure + ≡ function application +. ≡ (.) +$W ≡ ($ star(C w)) +``` + +By repeatedly applying composition law for w, we get: + +```haskell + +pY <*> u <*> (pW <*> v <*> w) == + +p. <*> (pY <*> u) <*> (pW <*> v) <*> w == + +p. <*> p. <*> pY <*> u <*> (pW <*> v) <*> w == + +p. <*> (p. <*> p. <*> pY <*> u) <*> pW <*> v <*> w == + +p. <*> (p..Y <*> u) <*> pW <*> v <*> w == + +p. <*> p. <*> p..Y <*> u <*> pW <*> v <*> w == + +p..(..Y) <*> u <*> pW <*> v <*> w == + +p($W) <*> (p..(..Y) <*> u) <*> v <*> w == + +p.($W)(..(..Y)) <*> u <*> v <*> w + + +(.) == \f -> \g -> \x -> f (g x) + +($W) == \g -> g W + +($W) . (..(..Y)) == \s -> (\g -> g W) ((..(..Y)) s) + == \s -> (..(..Y)) s W + +(. . (..Y)) == (\s -> . ((..Y) s)) + +∴ ($W) . (..(..Y)) == \s -> ((..Y) s) . W + +(..Y) == (\y -> (.) (Y y)) + +∴ ($W) . (..(..Y)) == \s -> ((.) (Y s)) . W + + == \s -> \t -> ((.) (Y s)) (W t) + + == \s -> \t -> (Y s) . (W t) + + == \s -> \t -> u -> (Y s (W t u)) +``` + +Undoing shorthands and α-converting, we get: + +```haskell +.($W)(..(..Y)) == + +\a :< m -> b :< n -> c :< p -> (Y (a :< m) (W (b : b :< n -> c :< p -> + (Y (a :< m) (b c :< (fmap (fmap b) p) <|> + (fmap (<*> C w) n))) == + +\a :< m -> b :< n -> c :< p -> + (Y (a :< m) (b c :< (fmap (fmap b) p) <|> + (fmap (<*> C w) n))) == + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap a) ((fmap (fmap b) p) <|> + (fmap (<*> C w) n))) + <|> + (fmap (<*> (C v <*> C w)) m)) + +== {- fmap distributes over <|>, fmap respects composition -} + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap ((fmap a) . (<*> C w)) n) <|> + (fmap (<*> (C v <*> C w)) m)) + +== + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap (\x -> pure a <*> (x <*> C w)) n) <|> + (fmap (\x -> x<*> (C v <*> C w)) m) ) +``` + +## Homomorphism + +```haskell + + pure f <*> pure x + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> pure x) t)) <$> + pure (f :< empty) <*> pure (x :< empty) + +== {- homomorphism law for w, twice -} + + C $ pure $ + let (b :< n) = bimap f (fmap f) (x :< empty) in + b :< (n <|> fmap (<*> pure x) empty)) + +== {- bimap -} + + C $ pure $ + let (b :< n) = (f x :< (fmap f empty)) in + b :< (n <|> fmap (<*> pure x) empty)) + +== {- empty invariant under fmap -} + + C $ pure $ (f x) :< (empty <|> empty) + +== {- definition -} + + pure (f x) + +``` + +## Interchange + +```haskell + + u <*> pure y + +== {- definition of <*>, pure -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) <$> u <*> (pure (y :< empty)) + +== {- interchange law for w -} + + C $ + pure ($ y :< empty) <*> + (pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t))) <*> u) + +== {- composition -} + + C $ + pure (.) <*> + pure ($ y :< empty) <*> + pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + + <*> u) + +== {- homomorphism -} + + C $ + pure (($ y :< empty) .) <*> + pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + + <*> u) + +== {- homomorphism -} + + C $ + pure (($ y :< empty) . + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- β-reduction -} + + C $ + pure ( + ( \(f :< t) -> + let (b :< n) = bimap f (fmap f) (y :< empty) in + b :< (n <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- bimap, β-reduction -} + + C $ + pure ( + ( \(f :< t) -> f y :< (empty <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- fmap -} + + C $ (\(f :< t) -> f y :< (fmap (<*> pure y) t)) <$> u + +== {- coinduction (consume 1, produce 1) -} + + C $ (\(f :< t) -> f y :< (fmap ($ y) t)) <$> u + +== {- def. $ -} + + C $ (\(f :< t) -> ($ y) f :< (fmap ($ y) t)) <$> u + +== {- def. bimap -} + + C $ bimap ($ y) (fmap ($ y)) <$> u + +== {- β,η-expansion -} + + C $ + ( + \(a) -> + let (b :< n) = bimap ($ y) (fmap ($ y)) a in + b :< n) <$> u + +== {- empty inviariant under fmap -} + + C $ + ( + \(a) -> + let (b :< n) = bimap ($ y) (fmap ($ y)) a in + b :< (n <|> fmap (<*> u) empty)) <$> u + +== {- fmap over pure -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> u) t)) <$> (pure (($ y) :< empty)) <*> u + +== {- definition -} + +pure ($ y) <*> u +``` + +## Consistency with Monad definition + +```haskell +instance (Alternative f, Monad w) => Monad (CofreeT f w) where + return = CofreeT . return . (:< empty) + (CofreeT cx) >>= f = CofreeT $ do + (a :< m) <- cx + (b :< n) <- runCofreeT $ f a + return $ b :< (n <|> fmap (>>= f) m) +``` + +If w is also a monad, then ```(<*>) == ap```. + +The proof uses coinduction for the case “produce one, consume one”. + +_Remark:_ If ```g = (\f -> (CofreeT wa) >>= (\a -> return $ f a))```, then + ```(`ap` a) == (>>= g)```. + +```haskell + +(C wf) `ap` (C wa) + +== {- definition -} + +(C wf) >>= (\f -> (C wa) >>= (\a -> f a)) + +== {- definition -} + + wf >>= \(f :< t) -> + unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (>>= g) t) + +== {- coinductive step -} + + wf >>= \(f :< t) -> + unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) +== {- definition of fmap for monads -} + + + wf >>= \(f :< t) -> + unC (fmap f (C wa)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- definition of fmap for C -} + + wf >>= \(f :< t) -> + fmap (bimap f (fmap f)) wa >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- definition of fmap for monads -} + + wf >>= \(f :< t) -> + (wa >>= (\a -> return (bimap f (fmap f) a) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- associativity of monads -} + + wf >>= \(f :< t) -> + wa >>= \a -> + (return (bimap f (fmap f a))) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> a) m) + +== {- Left identity of monads -} + + wf >>= \(f :< t) -> + wa >>= \(a -> + let b :< n = bimap f (fmap f a)) in + return $ b :< (n <|> fmap (<*> a) m)) + +== {- Equivalence of (>>=) and (<*>) for monad w. -} + + \(f :< t) -> + \(a -> + let b :< n = bimap f (fmap f a)) in + return $ b :< (n <|> fmap (<*> a) m))) + +== {- definition of (<*>) -} + +(CofreeT wf) <*> (CofreeT wa) + +``` + + diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md @@ -0,0 +1,200 @@ +Monad instance for CofreeT +========================== + +If the underlying functor f is an instance of Alternative, then CofreeT is also +a Monad. + +Note that the only required properties of Alternative are associativity and +identity element, so one could also use functors that are instances of Plus +(semigroupoid package). + +```haskell +instance (Alternative f, Monad w) => Monad (CofreeT f w) where + return = CofreeT . return . (:< empty) + (CofreeT cx) >>= f = CofreeT $ do + (a :< m) <- cx + (b :< n) <- runCofreeT $ f a + return $ b :< (n <|> fmap (>>= f) m) +``` + +This definition is equivalent to that of the Cofree module if 'w' is +identity. + +The tokens `CofreeT` and `runCofreeT` are abbreviated as `C` and `unC`, +respectively, for readability. + +## Left identity + +```haskell +return x >>= f + +== {- definition of return -} + +C (return (x :< empty)) >>= f + +== {- definition of bind -} + +C $ (return (x :< empty)) >>= (\a :< m -> + unC (f a) >>= (\b :< n -> + return $ b :< (n <|> fmap (>>= f) m) + +== {- Left identity for 'w' -} + + C $ unC (f x) >>= (\b :< n -> + return $ b :< (n <|> fmap (>>= f) empty) + +== {- fmap over empty -} + + C $ unC (f x) >>= (\b :< n -> + return $ b :< (n <|> fmap (>>= f) empty) + +== {- empty is identity for <|> -} == + + C $ unC (f x) >>= (\b :< n -> + return $ b :< n + +== {- η-reduction, right identity for w -} + + C $ unC (f x) +== + +f x +``` + +## Right identity + +```haskell + + (C wx) >>= return + +== {- definition of return -} + + (C wx) >>= (\x -> C $ return $ (x :< empty)) + +== {- definition of bind -} + + C $ wx >>= (\a :< m -> unC (C $ return $ a :< empty) + >>= (\b :< n -> return $ b :< (n <|> fmap (>>= return) m) + +== {- coinduction (“produce 1, consume 1”) -} + + C $ wx >>= (\a :< m -> unC (C $ return $ a :< empty) + >>= (\b :< n -> return $ b :< (n <|> fmap id m) + +== {- fmap id == id -} + + C $ wx >>= (\a :< m -> + unC (C $ return $ a :< empty) >>= (\b :< n -> + return $ b :< (n <|> m) + +== {- unC . C == id, left identity for w -} + + C $ wx >>= (\a :< m -> + let b :< n = a :< empty in + return $ b :< (n <|> m) + +== {- β-equivalence -} + + C $ wx >>= (\a :< m -> return $ a :< (empty <|> m)) + +== {- empty is identity for <|> -} + + C $ wx >>= (\a :< m -> return $ a :< m)) + +== {- right identity for w -} + + C wx +``` + +## Associativity + +```haskell + (C wa >>= g) >>= h + +== {- definition -} + + C $ do + unC (C wa >>= g) >>= \(c :< o) -> + unC $ h c >>= \(d :< p) _> + return $ d :< (p <|> fmap (>>= h) o) + +== {- definition -} + + C $ do + (wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + return $ b :< (m <|> fmap (>>= g) n) + ) >>= \(c :< o) -> + unC $ h c >>= \(d :< p) _> + return $ d :< (p <|> fmap (>>= h) o) + +== {- associativity of 'w' -} + + C $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + return $ b :< (m <|> fmap (>>= g) m) >>= \(c :< o) -> + unC $ h c >>= \(d :< p) _> + return $ d :< (p <|> fmap (>>= h) o) + +== {- left identity -} + C $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) _> + return $ d :< (p <|> fmap (>>= h) (n <|> fmap (>>= g) m)) + +== {- fmap distributes over (<|>), <|> is associative -} + + C $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) + return $ d :< (p <|> (fmap (>>= h) n) <|> fmap (>>= h) (fmap (>>= g) m)) + +== {- ∀f ∀g . fmap (f . g) == fmap f . fmap g -} + C $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) + return $ d :< (p <|> (fmap (>>= h) n) <|> fmap ((>>= h) . (>>= g)) m) + +== {- coinduction -} + + C $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) + return $ d :< (p <|> (fmap (>>= h) n) <|> fmap (>>= (\x -> g x >>= h)) m) + +== {- associativity of <|> -} + + c $ do + wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) + return $ d :< ((p <|> fmap (>>=h) n) <|> fmap (>>= (\x -> g x >>= h)) m + +== {- associativity, right identity for monads -} + c $ do + (wa >>= \(a :< m) -> + unC (g a) >>= \(b :< n) -> + unC (h b) >>= \(d :< p) + return (d :< (p <|> (fmap >>= h) n))) >>= \(c :< o) -> + return $ c :< (o <|> fmap (>>= (\x -> g x >>= h)) m + +== {- definition of bind -} + + C $ do + wa >>= \(a :< m) -> + unC (g a >>= h) >>= \(c :< o) -> + return $ c :< (o <|> fmap (>>= (\x -> g x >>= h)) m) + +== {- definition of bind -} + + (C wa) >>= (\x -> g x >>= h) +``` + +## Consistency with Applicative definition + +See [proof for applicative instance](instance-Applicative-CofreeT.md#consistency-with-monad-definition). diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md @@ -0,0 +1,88 @@ +MonadTrans instance for CofreeT +=============================== + +If the ```Functor f``` is an instance of ```Plus``` (or of ```Alternative```) +then CofreeT is a monad transformer. + +## Lift `return` + +```haskell +lift (return x) + +== {- definition lift -} + +C $ (liftM (:< empty) (return x)) + +== {- definition liftM -} + +C $ (return x) >>= (\a -> return $ a :< empty) + +== {- monad left identity -} + +C $ return $ x :< empty + +== {- definition -} + +return x +``` + +## Lift distributes over `bind` + +```haskell +lift (m >>= f) + +== {- definition lift -} + +C $ (liftM (:< empty) (m >>= f)) + +== {- definition liftM -} + +C $ (m >>= f) >>= (\a -> return $ a :< empty) + +== {- α-equivalence -} + +C $ m >>= f >>= (\b -> return $ b :< empty) + +== {- η-equivalence -} + +C $ m >>= \a -> + f a >>= \b -> + return $ b :< empty + +== {- empty invariant under fmap, empty identity -} + +C $ m >>= \a -> + f a >>= \b -> + return $ b :< (empty <|> fmap (>>= …) empty) + +== {- left identity -} + +C $ m >>= \a -> + return (a :< empty) >>= \a :< n -> + f a >>= \b -> + return (b :< empty) >>= \b :< m -> + return $ b :< (n <|> fmap (>>= …) m) + + +== {- associativity of >>= -} + +C $ (m >>= (\a -> return $ a :< empty)) >>= \a :< n -> + ((f a) >>= (\b -> return $ b :< empty)) >>= \b :< m -> + return $ b :< (n <|> fmap (>>= …) m) + +== {- pattern matching on CofreeF -} + +(C (m >>= (\a -> return $ a :< empty)) >>= (\x -> C ((f x) >>= (\b -> return b :< empty))) + +== {- definition lift -} + +(C (m >>= (\a -> return $ a :< empty)) >>= (\x -> lift (f x)) + +== {- definition lift -} + +lift m >>= (lift . f) +``` + + + + diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md new file mode 100644 --- /dev/null +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md @@ -0,0 +1,448 @@ +MonadZip instance for CofreeT +============================= + +For every monad `m` with a `MonadZip` instance and functor `f` with +`Alternative` and `MonadZip` instances, `CofreeT f m` is an instance of +`MonadZip`. + +```haskell +instance (Alternative f, MonadZip f, MonadZip m) => MonadZip (CofreeT f m) where + mzip (CofreeT ma) (CofreeT mb) = CofreeT $ do + (a :< fa, b :< fb) <- mzip ma mb + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) +``` + +This definition is equivalent to that of the `Cofree` module if `m` is +chosen to be the `Identity` monad. + +The claim follows directly from the two lemmata below, which establish +the `MonadZip` laws for naturality and information preservation +respectively, and the [`Monad` instance theorem for +`CofreeT`](instance-Monad-CofreeT.md). + +In the following, the tokens `CofreeT` and `runCofreeT` are abbreviated +as `C` and `unC` respectively. + +## Naturality + +```haskell +liftM (f *** g) (mzip ma mb) == mzip (liftM f ma) (liftM g mb) +``` + +### Proof. + +```haskell + liftM (f *** g) (mzip ma mb) + +== {- Definition of `liftM` -} + + mzip ma mb >>= return . (f *** g) + +== {- Definition of `mzip` -} + + C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + >>= return . (f *** g) + +== {- Definition of `(>>=)` -} + + C $ do c :< m <- do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + d :< n <- unC $ return $ (f *** g) c + return $ d :< (n <|> fmap (>>= return . f *** g) m) + +== {- `Monad` law `m >>= (\x -> k x >>= h) == (m >>= k) >>= h` -} + + C $ do a :< fa <- unC ma + c :< m <- do b :< fb <- unC mb + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + d :< n <- unC $ return $ (f *** g) c + return $ d :< (n <|> fmap (>>= return . f *** g) m) + +== {- `Monad` law `m >>= (\x -> k x >>= h) == (m >>= k) >>= h` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + c :< m <- return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + d :< n <- unC $ return $ (f *** g) c + return $ d :< (n <|> fmap (>>= return . f *** g) m) + +== {- `Monad` law `return a >>= k == k a` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + d :< n <- unC $ return $ (f *** g) (a, b) + return $ d :< (n <|> fmap (>>= return . f *** g) (uncurry mzip <$> mzip fa fb)) + +== {- Definition of `return` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + d :< n <- unC $ C $ return $ (f *** g) (a, b) :< empty + return $ d :< (n <|> fmap (>>= return . f *** g) (uncurry mzip <$> mzip fa fb)) + +== {- Unpack -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + d :< n <- return $ (f *** g) (a, b) :< empty + return $ d :< (n <|> fmap (>>= return . f *** g) (uncurry mzip <$> mzip fa fb)) + +== {- `Monad` law `return a >>= k == k a` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< (empty <|> fmap (>>= return . f *** g) (uncurry mzip <$> mzip fa fb)) + +== {- Identity of `<|>` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< fmap (>>= return . f *** g) (uncurry mzip <$> mzip fa fb) + +== {- Definition of `liftM` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< fmap (liftM (f *** g)) (uncurry mzip <$> mzip fa fb) + +== {- Definition of `<$>` -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< fmap (liftM (f *** g)) (fmap (uncurry mzip) $ mzip fa fb) + +== {- `Functor` composition -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< fmap (liftM (f *** g) . uncurry mzip) $ mzip fa fb + +== {- Coinduction hypothesis -} + + C $ do a :< fa <- unC ma + b :< fb <- unC mb + return $ (f *** g) (a, b) :< fmap (uncurry mzip . liftM f *** liftM g) $ mzip fa fb + +== {- `Functor` composition -} + + C $ do c :< m <- unC ma + k :< o <- unC mb + return $ (f c, g k) :< fmap (uncurry mzip) $ fmap (liftM f *** liftM g) $ mzip m o + +== {- `MonadZip` naturality -} + + C $ do c :< m <- unC ma + k :< o <- unC mb + return $ (f c, g k) :< fmap (uncurry mzip) $ mzip (fmap (liftM f) m) (fmap (liftM g) o)) + +== {- Definition of `<$>` -} + + C $ do c :< m <- unC ma + k :< o <- unC mb + return $ (f c, g k) :< (uncurry mzip <$> mzip (fmap (liftM f) m) (fmap (liftM g) o)) + +== {- Definition of `liftM` -} + + C $ do c :< m <- unC ma + k :< o <- unC mb + return $ (f c, g k) :< (uncurry mzip <$> mzip (fmap (>>= return . f) m) (fmap (>>= return . g) o)) + +== {- `Monad` law `return a >>= k == k a` -} + + C $ do c :< m <- unC ma + a :< fa <- return $ f c :< fmap (>>= return . f) m + k :< o <- unC mb + b :< fb <- return $ g k :< fmap (>>= return . g) o + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- `Alternative` identity -} + + C $ do c :< m <- unC ma + a :< fa <- return $ f c :< (empty <|> fmap (>>= return . f) m) + k :< o <- unC mb + b :< fb <- return $ g k :< (empty <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- `Monad` law `return a >>= k == k a` -} + + C $ do c :< m <- unC ma + d :< n <- return $ f c :< empty + a :< fa <- return $ d :< (n <|> fmap (>>= return . f) m) + k :< o <- unC mb + l :< p <- return $ g k :< empty + b :< fb <- return $ l :< (p <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- Unpack -} + + C $ do c :< m <- unC ma + d :< n <- unC $ C $ return $ f c :< empty + a :< fa <- unC $ C $ return $ d :< (n <|> fmap (>>= return . f) m) + k :< o <- unC mb + l :< p <- unC $ C $ return $ g k :< empty + b :< fb <- unC $ C $ return $ l :< (p <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- Definition of `return` -} + + C $ do c :< m <- unC ma + d :< n <- unC $ return $ f c + a :< fa <- unC $ C $ return $ d :< (n <|> fmap (>>= return . f) m) + k :< o <- unC mb + l :< p <- unC $ return $ g k + b :< fb <- unC $ C $ return $ l :< (p <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- `Monad` law `m >>= (\x -> k x >>= h) == (m >>= k) >>= h` -} + + C $ do c :< m <- unC ma + a :< fa <- unC $ C $ do d :< n <- unC $ return $ return $ f c + return $ d :< (n <|> fmap (>>= return . f) m) + k :< o <- unC mb + b :< fb <- unC $ C $ do l :< p <- unC $ return $ return g k + return $ l :< (p <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- `Monad` law `m >>= (\x -> k x >>= h) == (m >>= k) >>= h` -} + + C $ do a :< fa <- unC $ C $ do c :< m <- unC ma + d :< n <- unC $ return $ f c + return $ d :< (n <|> fmap (>>= return . f) m) + b :< fb <- unC $ C $ do k :< o <- unC mb + l :< p <- unC $ return $ g k + return $ l :< (p <|> fmap (>>= return . g) o) + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- Definition of `(>>=)` -} + + C $ do a :< fa <- unC $ ma >>= return . f + b :< fb <- unC $ mb >>= return . g + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- Definition of `liftM` -} + + C $ do a :< fa <- unC $ liftM f ma + b :< fb <- unC $ liftM g mb + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) + +== {- Definition of `mzip` -} + + mzip (liftM f ma) (liftM g mb) + +. +``` + +## Information Preservation + +```haskell +liftM (const ()) ma == liftM (const ()) mb --> munzip (mzip ma mb) == (ma, mb) +``` + +### Proof. + +```haskell + munzip (mzip ma mb) + +== {- Definition of `munzip` -} + + (,) + (liftM fst $ mzip ma mb) + (liftM snd $ mzip ma mb) + +== {- Definition of `mzip` -} + + (,) + (liftM fst $ C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb) + (liftM snd $ C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb) + +== {- Definition of `liftM` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + >>= return . fst) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + >>= return . snd) + +== {- Definition of `(>>=)` -} + + (,) + (C $ do c :< fc <- do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + d :< fd <- unC $ return $ fst c + return $ d :< $ fd <|> fmap (>>= return . fst) fc) + (C $ do c :< fc <- do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + d :< fd <- unC $ return $ snd c + return $ d :< $ fd <|> fmap (>>= return . snd) fc) + +== {- `Monad` law `m >>= (\x -> k x >>= h) == (m >>= k) >>= h` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + c :< fc <- return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + d :< fd <- unC $ return $ fst c + return $ d :< $ fd <|> fmap (>>= return . fst) fc) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + c :< fc <- return $ (a, b) :< fmap (uncurry mzip) $ mzip fa fb + d :< fd <- unC $ return $ snd c + return $ d :< $ fd <|> fmap (>>= return . snd) fc) + +== {- `Monad` law `return a >>= k == k a` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- unC $ return $ fst (a, b) + return $ d :< $ fd <|> fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- unC $ return $ snd (a, b) + return $ d :< $ fd <|> fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- Definition of `return` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- unC $ C $ return $ fst (a, b) :< empty + return $ d :< $ fd <|> fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- unC $ C $ return $ snd (a, b) :< empty + return $ d :< $ fd <|> fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- Unpack -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- return $ fst (a, b) :< empty + return $ d :< $ fd <|> fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + d :< fd <- return $ snd (a, b) :< empty + return $ d :< $ fd <|> fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- `Monad` law `return a >>= k == k a` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ fst (a, b) :< $ empty <|> fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ snd (a, b) :< $ empty <|> fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- `Alternative` identity -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ fst (a, b) :< fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ snd (a, b) :< fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- Definition of `fst` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fmap (>>= return . fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fmap (>>= return . snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- Definition of `liftM` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fmap (liftM fst) $ fmap (uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fmap (liftM snd) $ fmap (uncurry mzip) $ mzip fa fb) + +== {- `Functor` composition -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fmap (liftM fst . uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fmap (liftM snd . uncurry mzip) $ mzip fa fb) + +== {- Definition of `unzip` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fmap (fst . unzip . uncurry mzip) $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fmap (snd . unzip . uncurry mzip) $ mzip fa fb) + +== {- Coinduction hypothesis -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fmap fst $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fmap snd $ mzip fa fb) + +== {- `Monad` law `fmap f m == m >>= return . f` and definition of `liftM` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< liftM fst $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< liftM snd $ mzip fa fb) + +== {- Definition of `unzip` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fst $ unzip $ mzip fa fb) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< snd $ unzip $ mzip fa fb) + +== {- `MonadZip` information preservation -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fst (fa, fb)) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< snd (fa, fb)) + +== {- Definition of `fst` and `snd` -} + + (,) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ a :< fa) + (C $ do (a :< fa, b :< fb) <- mzip (unC ma) (unC mb) + return $ b :< fb) + +== {- Definition of `fst` and `snd` -} + + (,) + (C $ mzip (unC ma) (unC mb) >>= return . fst) + (C $ mzip (unC ma) (unC mb) >>= return . snd) + +== {- Definition of `liftM` -} + + (,) + (C $ liftM fst $ mzip (unC ma) (unC mb)) + (C $ liftM snd $ mzip (unC ma) (unC mb)) + +== {- Definition of `unzip` -} + + (,) + (C $ fst $ unzip $ mzip (unC ma) (unC mb)) + (C $ snd $ unzip $ mzip (unC ma) (unC mb)) + +== {- `MonadZip` information preservation -} + + (,) + (C $ fst $ (unC ma, unC mb)) + (C $ snd $ (unC ma, unC mb)) + +== {- Definition of `fst` and `snd` -} + + (,) + (C $ unC ma) + (C $ unC mb) + +== {- Pack -} + + (ma, mb) + +. +``` diff --git a/examples/Cabbage.lhs b/examples/Cabbage.lhs new file mode 100644 --- /dev/null +++ b/examples/Cabbage.lhs @@ -0,0 +1,207 @@ +> {-# LANGUAGE ViewPatterns #-} +> module Cabbage where + +> import Control.Monad +> import Control.Monad.State +> import Control.Monad.Trans.Iter +> import Control.Monad.Writer +> import Data.Functor.Identity +> import Data.Maybe +> import Data.Tuple +> import Data.List (inits, tails) + +Consider the following problem: + +A farmer must cross a river with a wolf, a sheep and a cabbage. +He owns a boat, which can only carry himself and one other item. +The sheep must not be left alone with the wolf, or with the cabbage: +if that happened, one of them would eat the other. + +> data Item = Wolf | Sheep | Cabbage | Farmer deriving (Ord, Show, Eq) +> +> eats :: Item -> Item -> Bool +> Sheep `eats` Cabbage = True +> Wolf `eats` Sheep = True +> _ `eats` _ = False + +The problem can be represented as the set of items on each side of the river. + +> type Situation = ([Item],[Item]) + +> initial :: Situation +> initial = ([Farmer, Wolf, Sheep, Cabbage], []) + +First, some helper functions to extract single elements from lists, leaving the +rest intact: + +> plusTailOf :: [a] -> [a] -> (Maybe a, [a]) +> a `plusTailOf` b = (listToMaybe b, a ++ drop 1 b) + +> singleOut1 :: (a -> Bool) -> [a] -> (Maybe a,[a]) +> singleOut1 sel = uncurry plusTailOf . break sel + +@ +*Cabbage> singleOut1 (== Sheep) [Wolf, Sheep, Cabbage] +(Just Sheep,[Wolf,Cabbage]) +@ + +> singleOutAll :: [a] -> [(Maybe a,[a])] +> singleOutAll = zipWith plusTailOf <$> inits <*> tails + +@ +*Cabbage> singleOutAll [Wolf, Sheep, Cabbage] +[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])] +@ + +In every move, the farmer goes from one side of the river to the other, +together with (optionally) one item. + +The remaining items must not eat each other for the move to be valid. + +> move :: Situation -> [Situation] +> move = move2 +> where +> move2 (singleOut1 (== Farmer) -> (Just Farmer,as), bs) = move1 as bs +> move2 (bs, singleOut1 (== Farmer) -> (Just Farmer,as)) = map swap $ move1 as bs +> move2 _ = [] +> +> move1 as bs = [(as', [Farmer] ++ maybeToList b ++ bs) | +> (b, as') <- singleOutAll as, +> and [not $ x `eats` y | x <- as', y <- as']] + +@ +*Cabbage> move initial +[([Wolf,Cabbage],[Farmer,Sheep])] +@ + +When the starting side becomes empty, the farmer succeeds. + +> success :: Situation -> Bool +> success ([],_) = True +> success _ = False + +A straightforward implementation to solve the problem could use the +list monad, trying all possible solutions and + +> solution1 :: Situation +> solution1 = head $ solutions' initial +> where +> solutions' a = if success a +> then return a +> else move a >>= solutions' + +However, when it's run, it will get stuck in an infinite loop, as the sheep +is shuffled back and forth. The solution is being searched in depth. + +To guarantee termination, we can use the 'Iter' monad with its MonadPlus instance. +As long as one of the possible execution paths finds a solution, the program +will terminate: the solution is looked for _in breadth_. + +> solution2 :: Iter Situation +> solution2 = solution' initial +> where +> solution' a = +> if success a +> then return a +> else delay $ msum $ map solution' (move a) + +Each of the alternative sequences of movements will be evaluated +concurrently; and the shortest one will be the result. In case of ties, +the leftmost solution takes priority. + +@ + *Cabbage> solution2 + IterT (Identity (Right ( … + (IterT (Identity (Right + (IterT (Identity (Left + ([],[Farmer,Sheep,Cabbage,Wolf])))))))))))))))))))))))) +@ + +For a cleaner display, use 'retract' to escape 'Iter' monad: + +@ + *Cabbage> retract solution2 + Identity ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +'unsafeIter' will also get rid of the 'Identity' wrapper: + +> unsafeIter :: Iter a -> a +> unsafeIter = runIdentity . retract + +@ + *Cabbage> unsafeIter solution2 + ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +Suppose that we not only want the solution, but also the steps that we +took to arrive there. Enter the Writer monad transformer: + +> solution3 :: Iter (Situation, [Situation]) +> solution3 = runWriterT $ solution' initial +> where +> solution' :: Situation -> WriterT [Situation] Iter Situation +> solution' a = do +> tell [a] +> if success a +> then return a +> else mapWriterT delay $ msum $ map solution' (move a) + +The second component contains the complete path to the solution: + +@ + *Cabbage> snd $ unsafeIter solution3 + [([Farmer,Wolf,Sheep,Cabbage],[]), + ([Wolf,Cabbage],[Farmer,Sheep]), + ([Farmer,Wolf,Cabbage],[Sheep]), + ([Cabbage],[Farmer,Wolf,Sheep]), + ([Farmer,Sheep,Cabbage],[Wolf]), + ([Sheep],[Farmer,Cabbage,Wolf]), + ([Farmer,Sheep],[Cabbage,Wolf]), + ([],[Farmer,Sheep,Cabbage,Wolf])] +@ + +When the transformer is applied _over_ the Iter monad, it acts locally for each solution. +If we apply the IterT transformer over another monad, +the behaviour for that monad will be shared among all threads. + +For example, let's keep track of how many moves we perform. We could +do so with the writer monad again (numbers form a monoid under addition), but +we'll use the state monad this time. + +> solution4 :: Iter (Situation, Integer) +> solution4 = flip runStateT 0 $ solution' initial +> where +> solution' :: Situation -> StateT Integer Iter Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> mapStateT delay $ msum $ map solution' (move a) + +This gives us seven moves (one for each transition between two states). + +@ + *Cabbage> unsafeIter solution4 + (([],[Farmer,Sheep,Cabbage,Wolf]),7) +@ + +On the other hand, if move the state inside Iter, we get a global count of +explored nodes until the solution was found. + +> solution5 :: State Integer Situation +> solution5 = retract $ solution' initial +> where +> solution' :: Situation -> IterT (State Integer) Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> delay $ msum $ map solution' (move a) + +@ + *Cabbage> runState solution5 0 + (([],[Farmer,Sheep,Cabbage,Wolf]),113) +@ diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 --- /dev/null +++ b/examples/LICENSE @@ -0,0 +1,30 @@ +Copyright 2008-2013 Edward Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/MandelbrotIter.lhs b/examples/MandelbrotIter.lhs new file mode 100644 --- /dev/null +++ b/examples/MandelbrotIter.lhs @@ -0,0 +1,137 @@ +Compiling to an executable file with the @-O2@ optimization level is recommended. + +For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@ + +> {-# LANGUAGE PackageImports #-} +> module Main where + +> import Control.Arrow hiding (loop) +> import Control.Monad.IO.Class (MonadIO(..)) +> import Control.Monad.Trans.Iter +> import "mtl" Control.Monad.Reader (ReaderT, runReaderT, asks) +> import Data.Complex +> import Graphics.HGL (runGraphics, Window, withPen, +> line, RGB (RGB), RedrawMode (DoubleBuffered), openWindowEx, +> drawInWindow, mkPen, Style (Solid)) + +Some fractals can be defined by infinite sequences of complex numbers. For example, +to render the , +the following sequence is generated for each point @c@ in the complex plane: + +@ +z₀ = c + +z₁ = z₀² + c + +z₂ = z₁² + c + +… +@ + +If, after some iterations, |z_i| ≥ 2, the point is not in the set. We +can compute if a point is not in the Mandelbrot set this way: + +@ + escaped :: Complex Double -> Int + escaped c = loop 0 0 where + loop z n = if (magnitude z) >= 2 then n + else loop (z*z + c) (n+1) +@ + +If @c@ is not in the Mandelbrot set, we get the number of iterations required to +prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will +run forever. + +We can use the 'Iter' monad to delimit this effect. By applying +'delay' before the recursive call, we decompose the computation into +terminating steps. + +> escaped :: Complex Double -> Iter Int +> escaped c = loop 0 0 where +> loop z n = if (magnitude z) >= 2 then return n +> else delay $ loop (z*z + c) (n+1) +> + +If we draw each point on a canvas after it escapes, we can get a _negative_ +image of the Mandelbrot set. Drawing pixels is a side-effect, so it +should happen inside the IO monad. Also, we want to have an +environment to store the size of the canvas, and the target window. + +By using 'IterT', we can add all these behaviours to our non-terminating +computation. + +> data Canvas = Canvas { width :: Int, height :: Int, window :: Window } +> +> type FractalM a = IterT (ReaderT Canvas IO) a + +Any simple, non-terminating computation can be lifted into a richer environment. + +> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int +> escaped' = liftIter . escaped + +Then, to draw a point, we can just retrieve the number of iterations until it +finishes, and draw it. The color will depend on the number of iterations. + +> mandelbrotPoint :: (Int, Int) -> FractalM () +> mandelbrotPoint p = do +> c <- scale p +> n <- escaped' c +> let color = if (even n) then RGB 0 0 255 -- Blue +> else RGB 0 0 127 -- Darker blue +> drawPoint color p + +The pixels on the screen don't match the region in the complex plane where the +fractal is; we need to map them first. The region we are interested in is +Im z = [-1,1], Re z = [-2,1]. + +> scale :: (Int, Int) -> FractalM (Complex Double) +> scale (xi,yi) = do +> (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height) +> let (x,y) = (fromIntegral xi, fromIntegral yi) +> let im = (-y + h / 2 ) / (h/2) +> let re = ( x - w * 2 / 3 ) / (h/2) +> return $ re :+ im + +Drawing a point is equivalent to drawing a line of length one. + +> drawPoint :: RGB -> (Int,Int) -> FractalM () +> drawPoint color (x,y) = do +> w <- asks window +> let point = line (x,y) (x+1, y+1) +> liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point) + +We may want to draw more than one point. However, if we just sequence the computations +monadically, the first point that is not a member of the set will block the whole +process. We need advance all the points at the same pace, by interleaving the +computations. + +> drawMandelbrot :: FractalM () +> drawMandelbrot = do +> (w,h) <- asks $ width &&& height +> let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]] +> interleave_ ps + +To run this computation, we can just use @retract@, which will run indefinitely: + +> runFractalM :: Canvas -> FractalM a -> IO a +> runFractalM canvas = flip runReaderT canvas . retract + +Or, we can trade non-termination for getting an incomplete result, +by cutting off after a certain number of steps. + +> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a) +> runFractalM' n canvas = flip runReaderT canvas . retract . cutoff n + +Thanks to the 'IterT' transformer, we can separate timeout concerns from +computational concerns. + +> main :: IO () +> main = do +> let windowWidth = 800 +> let windowHeight = 480 +> runGraphics $ do +> w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1) +> let canvas = Canvas windowWidth windowHeight w +> _ <- runFractalM' 100 canvas drawMandelbrot +> putStrLn $ "Fin" + diff --git a/examples/NewtonCoiter.lhs b/examples/NewtonCoiter.lhs new file mode 100644 --- /dev/null +++ b/examples/NewtonCoiter.lhs @@ -0,0 +1,100 @@ +Many numerical approximation methods compute infinite sequences of results; each, +hopefully, more accurate than the previous one. + + +to find zeroes of a function is one such algorithm. + +> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} +> module Main where + +> import Control.Comonad.Trans.Coiter +> import Control.Comonad.Env +> import Data.Foldable (toList, find) + +> data Function = Function { +> -- Function to find zeroes of +> function :: Double -> Double, +> -- Derivative of the function +> derivative :: Double -> Double +> } +> +> data Result = Result { +> -- Estimated zero of the function +> value :: Double, +> -- Estimated distance to the actual zero +> xerror :: Double, +> -- How far is value from being an actual zero; that is, +> -- the difference between @0@ and @f value@ +> ferror :: Double +> } deriving (Show) +> +> data Outlook = Outlook { result :: Result, +> -- Whether the result improves in future steps +> progress :: Bool } deriving (Show) + +To make our lives easier, we will store the problem at hand using the Env +environment comonad. + +> type Solution a = CoiterT (Env Function) a + +Problems consist of a function and its derivative as the environment, and +an initial value. + +> type Problem = Env Function Double + +We can express an iterative algorithm using unfold over an initial environment. + +> newton :: Problem -> Solution Double +> newton = unfold (\wd -> +> let f = asks function wd in +> let df = asks derivative wd in +> let x = extract wd in +> x - f x / df x) +> +> + +To estimate the error, we look forward one position in the stream. The next value +will be much more precise than the current one, so we can consider it as the +actual result. + +We know that the exact value of a function at one of it's zeroes is 0. So, +@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@ + +> estimateError :: Solution Double -> Result +> estimateError s = +> let (a, s') = extract $ runCoiterT s in +> let a' = extract s' in +> let f = asks function s in +> Result { value = a, +> xerror = abs $ a - a', +> ferror = abs $ f a +> } + +To get a sense of when the algorithm is making any progress, we can sample the +future and check if the result improves at all. + +> estimateOutlook :: Int -> Solution Result -> Outlook +> estimateOutlook sampleSize solution = +> let sample = map ferror $ take sampleSize $ tail $ toList solution in +> let result' = extract solution in +> Outlook { result = result', +> progress = ferror result' > minimum sample } + +To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will +stop whenever the accuracy of the result doesn't improve in the next 5 steps. + +The starting value for our algorithm is @c@ itself. One could compute a better +estimate, but the algorithm converges fast enough that it's not really worth it. + +> squareRoot :: Double -> Maybe Result +> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c), +> derivative = (\x -> 2*x) }) +> in +> fmap result $ find (not . progress) $ +> newton problem =>> estimateError =>> estimateOutlook 5 + +This program will output the result together with the error. + +> main :: IO () +> main = putStrLn $ show $ squareRoot 3 + diff --git a/examples/PerfTH.hs b/examples/PerfTH.hs new file mode 100644 --- /dev/null +++ b/examples/PerfTH.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import System.CPUTime.Rdtsc +import System.IO.Unsafe +import Data.IORef +import Data.Word +import Control.Monad +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Control.Monad.Fail as Fail (MonadFail) +import Control.Monad.Free +import Control.Monad.Free.TH +import qualified Control.Monad.Free.Church as Church +import Control.Monad.Trans.State.Strict +import Text.Printf + +-- | A data type representing basic commands for our performance-testing eDSL. +data PerfF next where + Output :: String -> next -> PerfF next + Input :: (Show a, Read a) => (a -> next) -> PerfF next + +-- | Unfortunately this Functor instance cannot yet be derived +-- automatically by GHC. +instance Functor PerfF where + fmap f (Output s x) = Output s (f x) + fmap f (Input g) = Input (f . g) + +makeFreeCon 'Output +makeFreeCon 'Input + +type PerfCnt = Word64 + +-- | Unsafe state variable: base CPU cycles +{-# NOINLINE g_base_counter #-} +g_base_counter :: IORef PerfCnt +g_base_counter = unsafePerformIO $ do + rdtsc >>= newIORef + +-- | Prints number of CPU cycles since last call +g_print_time_since_prev_call :: (MonadIO m) => m () +g_print_time_since_prev_call = liftIO $ do + cb <- readIORef g_base_counter + c <- rdtsc + writeIORef g_base_counter c + putStr $ printf "\r%-10s" (show $ c - cb) + +-- | Free-based interpreter +runPerfFree :: (MonadIO m) => [String] -> Free PerfF () -> m () +runPerfFree [] _ = return () +runPerfFree (s:ss) x = case x of + Free (Output _o next) -> do + runPerfFree (s:ss) next + Free (Input next) -> do + g_print_time_since_prev_call + runPerfFree ss (next (read s)) + Pure a -> do + return a + +-- | Church-based interpreter +runPerfF :: (Fail.MonadFail m, MonadIO m) => [String] -> Church.F PerfF () -> m () +runPerfF [] _ = return () +runPerfF ss0 f = + fst `liftM` do + flip runStateT ss0 $ Church.iterM go f where + go (Output _o next) = do + next + go (Input next) = do + g_print_time_since_prev_call + (s:ss) <- get + put ss + next (read s) + +-- | Test input is the same for all cases +test_input :: [String] +test_input = [show i | i<-([1..9999] ++ [0 :: Int])] + +-- | Tail-recursive program +test_tail :: (MonadFree PerfF m) => m () +test_tail = do + output "Enter something" + (n :: Int) <- input + output $ "Just entered: " ++ (show n) + when (n > 0) $ do + test_tail + +run_tail_free,run_tail_f :: IO () +run_tail_free = runPerfFree test_input test_tail +run_tail_f = runPerfF test_input test_tail + + +-- | Deep-recursive program +test_loop :: (MonadFree PerfF m) => m () +test_loop = do + output "Enter something" + (n :: Int) <- input + when (n > 0) $ do + test_loop + output $ "Just entered: " ++ (show n) + +run_loop_free,run_loop_f :: IO () +run_loop_free = runPerfFree test_input test_loop +run_loop_f = runPerfF test_input test_loop + +main :: IO () +main = do + putStr $ unlines [ + "Running two kinds of FreeMonad programs against two kinds of interpreters.", + "Counters represent approx. number of CPU ticks per program iteration" ] + putStrLn ">> (1/4) Tail-recursive program/Free interpreter" + run_tail_free + putStrLn "\n>> (2/4) Tail-recursive program/Church interpreter" + run_tail_f + putStrLn "\n>> (3/4) Deep-recursive program/Free interpreter (a slower one)" + run_loop_free + putStrLn "\n>> (4/4) Deep-recursive program/Church interpreter" + run_loop_f + putStrLn "\n" + diff --git a/examples/RetryTH.hs b/examples/RetryTH.hs new file mode 100644 --- /dev/null +++ b/examples/RetryTH.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Control.Monad +import Control.Monad.Fail as Fail +import Control.Monad.Free +import Control.Monad.Free.TH +import Control.Monad.IO.Class +import Control.Monad.Trans.Instances () +import Control.Monad.Trans.Maybe +import qualified Data.Foldable as F +import Text.Read (readMaybe) + +-- | A data type representing basic commands for a retriable eDSL. +data RetryF next where + Output :: String -> next -> RetryF next + Input :: Read a => (a -> next) -> RetryF next + WithRetry :: Retry a -> (a -> next) -> RetryF next + Retry :: RetryF next + +-- | Unfortunately this Functor instance cannot yet be derived +-- automatically by GHC. +instance Functor RetryF where + fmap f (Output s x) = Output s (f x) + fmap f (Input g) = Input (f . g) + fmap f (WithRetry block g) = WithRetry block (f . g) + fmap _ Retry = Retry + +-- | The monad for a retriable eDSL. +type Retry = Free RetryF + +-- | Simple output command. +makeFreeCon 'Output + +-- | Get anything readable from input. +makeFreeCon 'Input + +-- | Force retry command (retries innermost retriable block). +makeFreeCon 'Retry + +makeFreeCon_ 'WithRetry +-- | Run a retryable block. +withRetry :: MonadFree RetryF m => + Retry a -- ^ Computation to retry. + -> m a -- ^ Computation that retries until succeeds. + +-- The following functions have been made available: +-- +-- output :: MonadFree RetryF m => String -> m () +-- input :: (MonadFree RetryF m, Read a) => m a +-- withRetry :: MonadFree RetryF m => Retry a -> m a +-- retry :: MonadFree RetryF m => m a + +-- | We can run a retriable program in any MonadIO. +runRetry :: (MonadFail m, MonadIO m) => Retry a -> m a +runRetry = iterM run + where + run :: (MonadFail m, MonadIO m) => RetryF (m a) -> m a + + run (Output s next) = do + liftIO $ putStrLn s + next + + run (Input next) = do + s <- liftIO getLine + case readMaybe s of + Just x -> next x + Nothing -> Fail.fail "invalid input" + + run (WithRetry block next) = do + -- Here we use + -- runRetry :: MonadIO m => Retry a -> MaybeT (m a) + -- to control failure with MaybeT. + -- We repeatedly run retriable block until we get it to work. + Just x <- runMaybeT . F.msum $ repeat (runRetry block) + next x + + run Retry = Fail.fail "forced retry" + +-- | Sample program. +test :: Retry () +test = do + n <- withRetry $ do + output "Enter any positive number: " + n <- input + when (n <= 0) $ do + output "The number should be positive." + retry + return n + output $ "You've just entered " ++ show (n :: Int) + +main :: IO () +main = runRetry test diff --git a/examples/Teletype.lhs b/examples/Teletype.lhs new file mode 100644 --- /dev/null +++ b/examples/Teletype.lhs @@ -0,0 +1,104 @@ +> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- +> module Main where + +> import qualified Control.Exception as E (catch) +> import Control.Monad (mfilter) +> import Control.Monad.Loops (unfoldM) +> import Control.Monad.Free (liftF, Free, iterM, MonadFree) +> import Control.Monad.Free.TH (makeFree) +> import System.IO (isEOF) +> import System.IO.Error (ioeGetErrorString) +> import System.Exit (exitSuccess) + +First, we define a data type with the primitive actions of a teleprinter. The +@param@ will stand for the next action to execute. + +> type Error = String +> +> data Teletype param = Halt -- Abort (ignore all following instructions) +> | NL param -- Newline +> | Read (Char -> param) -- Get a character from the terminal +> | ReadOrEOF { onEOF :: param, +> onChar :: Char -> param } -- GetChar if not end of file +> | ReadOrError (Error -> param) +> (Char -> param) -- GetChar with error code +> | param :\^^ String -- Write a message to the terminal +> | (:%) param String [String] -- String interpolation +> deriving (Functor) + +By including a 'makeFree' declaration: + +> makeFree ''Teletype + +the following functions have been made available: + +@ + halt :: (MonadFree Teletype m) => m a + nL :: (MonadFree Teletype m) => m () + read :: (MonadFree Teletype m) => m Char + readOrEOF :: (MonadFree Teletype m) => m (Maybe Char) + readOrError :: (MonadFree Teletype m) => m (Either Error Char) + (\\^^) :: (MonadFree Teletype m) => String -> m () + (%) :: (MonadFree Teletype m) => String -> [String] -> m () +@ + +To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a +'Functor', we can use the one provided in the 'Control.Monad.Free' package. + +> type TeletypeM = Free Teletype + +Programs can be run in different ways. For example, we can use the +system terminal through the @IO@ monad. + +> runTeletypeIO :: TeletypeM a -> IO a +> runTeletypeIO = iterM run where +> run :: Teletype (IO a) -> IO a +> run Halt = do +> putStrLn "This conversation can serve no purpose anymore. Goodbye." +> exitSuccess +> +> run (Read f) = getChar >>= f +> run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof +> else getChar >>= f +> +> run (ReadOrError ferror f) = E.catch (getChar >>= f) (ferror . ioeGetErrorString) +> run (NL rest) = putChar '\n' >> rest +> run (rest :\^^ str) = putStr str >> rest +> run ((:%) rest format tokens) = ttFormat format tokens >> rest +> +> ttFormat :: String -> [String] -> IO () +> ttFormat [] _ = return () +> ttFormat ('\\':'%':cs) tokens = putChar '%' >> ttFormat cs tokens +> ttFormat ('%':cs) (t:tokens) = putStr t >> ttFormat cs tokens +> ttFormat (c:cs) tokens = putChar c >> ttFormat cs tokens + +Now, we can write some helper functions: + +> readLine :: TeletypeM String +> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF + +And use them to interact with the user: + +> hello :: TeletypeM () +> hello = do +> (\^^) "Hello! What's your name?"; nL +> name <- readLine +> "Nice to meet you, %." % [name]; nL +> halt + +We can transform any @TeletypeM@ into an @IO@ action, and run it: + +> main :: IO () +> main = runTeletypeIO hello + +@ + Hello! What's your name? + $ Dave + Nice to meet you, Dave. + This conversation can serve no purpose anymore. Goodbye. +@ + +When specifying DSLs in this way, we only need to define the semantics +for each of the actions; the plumbing of values is taken care of by +the generated monad instance. + diff --git a/examples/ValidationForm.hs b/examples/ValidationForm.hs new file mode 100644 --- /dev/null +++ b/examples/ValidationForm.hs @@ -0,0 +1,113 @@ +module Main where + +import Control.Applicative.Free +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State + +import Data.Monoid (Sum(..)) + +import Text.Read (readEither) +import Text.Printf + +import System.IO + +-- | Field reader tries to read value or generates error message. +type FieldReader a = String -> Either String a + +-- | Convenient synonym for field name. +type Name = String + +-- | Convenient synonym for field help message. +type Help = String + +-- | A single field of a form. +data Field a = Field + { fName :: Name -- ^ Name. + , fValidate :: FieldReader a -- ^ Pure validation function. + , fHelp :: Help -- ^ Help message. + } + +-- | Validation form is just a free applicative over Field. +type Form = Ap Field + +-- | Build a form with a single field. +field :: Name -> FieldReader a -> Help -> Form a +field n f h = liftAp $ Field n f h + +-- | Singleton form accepting any input. +string :: Name -> Help -> Form String +string n h = field n Right h + +-- | Singleton form accepting anything but mentioned values. +available :: [String] -> Name -> Help -> Form String +available xs n h = field n check h + where + check x | x `elem` xs = Left "the value is not available" + | otherwise = Right x + +-- | Singleton integer field form. +int :: Name -> Form Int +int name = field name readEither "an integer value" + +-- | Generate help message for a form. +help :: Form a -> String +help = unlines . runAp_ (\f -> [fieldHelp f]) + +-- | Get help message for a field. +fieldHelp :: Field a -> String +fieldHelp (Field name _ msg) = printf " %-15s - %s" name msg + +-- | Count fields in a form. +count :: Form a -> Int +count = getSum . runAp_ (\_ -> Sum 1) + +-- | Interactive input of a form. +-- Shows progress on each field. +-- Repeats field input until it passes validation. +-- Show help message on empty input. +input :: Form a -> IO a +input m = evalStateT (runAp inputField m) 1 + where + inputField :: Field a -> StateT Int IO a + inputField f@(Field n g h) = do + i <- get + -- get field input with prompt + x <- liftIO $ do + putStr $ printf "[%d/%d] %s: " i (count m) n + hFlush stdout + getLine + case words x of + -- display help message for empty input + [] -> do + liftIO . putStrLn $ "help: " ++ h + inputField f + -- validate otherwise + _ -> case g x of + Right y -> do + modify (+ 1) + return y + Left e -> do + liftIO . putStrLn $ "error: " ++ e + inputField f + +-- | User datatype. +data User = User + { userName :: String + , userFullName :: String + , userAge :: Int } + deriving (Show) + +-- | Form for User. +form :: [String] -> Form User +form us = User + <$> available us "Username" "any vacant username" + <*> string "Full name" "your full name (e.g. John Smith)" + <*> int "Age" + +main :: IO () +main = do + putStrLn "Creating a new user." + putStrLn "Please, fill the form:" + user <- input (form ["bob", "alice"]) + putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!" + diff --git a/examples/free-examples.cabal b/examples/free-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/free-examples.cabal @@ -0,0 +1,109 @@ +name: free-examples +category: Control, Monads +version: 0.1 +license: BSD3 +cabal-version: 1.18 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/free/ +bug-reports: http://github.com/ekmett/free/issues +copyright: Copyright (C) 2008-2015 Edward A. Kmett +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.6 + , GHC == 9.4.4 + , GHC == 9.6.1 +synopsis: Monads for free +description: Examples projects using @free@ +build-type: Simple + +source-repository head + type: git + location: git://github.com/ekmett/free.git + +flag mandelbrot-iter + default: True + +library + hs-source-dirs: . + default-language: Haskell2010 + exposed-modules: Cabbage + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 + +executable free-mandelbrot-iter + if !flag(mandelbrot-iter) + buildable: False + hs-source-dirs: . + default-language: Haskell2010 + main-is: MandelbrotIter.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + HGL >= 3.2.3.2, + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 + +executable free-newton-coiter + hs-source-dirs: . + default-language: Haskell2010 + main-is: NewtonCoiter.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + comonad >= 4 && < 6, + free + +executable free-perf-th + hs-source-dirs: . + default-language: Haskell2010 + main-is: PerfTH.hs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + rdtsc, + transformers >= 0.2 && < 0.7 + +executable free-retry-th + hs-source-dirs: . + default-language: Haskell2010 + main-is: RetryTH.hs + ghc-options: -Wall -fno-warn-orphans + build-depends: + base >= 4.9 && < 5, + free, + transformers >= 0.2 && < 0.7, + transformers-compat >= 0.6.4 && < 0.8 + +executable free-teletype + hs-source-dirs: . + default-language: Haskell2010 + main-is: Teletype.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + monad-loops + +executable free-validation-form + hs-source-dirs: . + default-language: Haskell2010 + main-is: ValidationForm.hs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + transformers >= 0.2 && < 0.7 diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,38 +1,62 @@ name: free category: Control, Monads -version: 3.4.2 +version: 5.2 license: BSD3 -cabal-version: >= 1.10 +cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/free/ bug-reports: http://github.com/ekmett/free/issues -copyright: Copyright (C) 2008-2012 Edward A. Kmett +copyright: Copyright (C) 2008-2015 Edward A. Kmett +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.6 + , GHC == 9.4.4 + , GHC == 9.6.1 synopsis: Monads for free description: Free monads are useful for many tree-like structures and domain specific languages. . - A 'Monad' @n@ is a free 'Monad' for @f@ if every 'Monad' homomorphism - from @n@ to another monad @m@ is equivalent to a natural transformation - from @f@ to @m@. + If @f@ is a 'Functor' then the free 'Monad' on @f@ is the type + of trees whose nodes are labeled with the constructors of @f@. The word + \"free\" is used in the sense of \"unrestricted\" rather than \"zero-cost\": + @Free f@ makes no constraining assumptions beyond those given by @f@ and the + definition of 'Monad'. As used here it is a standard term from the + mathematical theory of adjoint functors. . - Cofree comonads provide convenient ways to talk about branching streams and rose-trees, - and can be used to annotate syntax trees. + Cofree comonads are dual to free monads. They provide convenient ways to talk + about branching streams and rose-trees, and can be used to annotate syntax + trees. The cofree comonad can be seen as a stream parameterized by a 'Functor' + that controls its branching factor. . - A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every 'Comonad' homomorphism - another comonad @w@ to @v@ is equivalent to a natural transformation - from @w@ to @f@. + More information on free monads, including examples, can be found in the + following blog posts: + + build-type: Simple extra-source-files: - .ghci .gitignore - .travis.yml + .hlint.yaml .vim.custom README.markdown CHANGELOG.markdown + doc/proof/Control/Comonad/Cofree/*.md + doc/proof/Control/Comonad/Trans/Cofree/*.md + examples/free-examples.cabal + examples/LICENSE + examples/*.hs + examples/*.lhs +extra-doc-files: + examples/*.hs + examples/*.lhs source-repository head type: git @@ -42,7 +66,6 @@ hs-source-dirs: src default-language: Haskell2010 - default-extensions: CPP other-extensions: MultiParamTypeClasses FunctionalDependencies @@ -52,31 +75,52 @@ GADTs build-depends: - base >= 4 && < 5, - bifunctors >= 3, - distributive >= 0.2.1, - transformers >= 0.2.0 && < 0.4, - mtl >= 2.0.1.0 && < 2.2, - semigroupoids >= 3, - comonad >= 3, - comonad-transformers >= 3, - comonads-fd >= 3, - semigroups >= 0.8.3.1, - profunctors >= 3.2 && < 4 + base >= 4.9 && < 5, + comonad >= 5.0.8 && < 6, + containers >= 0.5.7.1 && < 0.7, + distributive >= 0.5.2 && < 1, + exceptions >= 0.10.4 && < 0.11, + indexed-traversable >= 0.1.1 && < 0.2, + mtl >= 2.2.2 && < 2.4, + profunctors >= 5.6.1 && < 6, + semigroupoids >= 5.3.5 && < 6, + th-abstraction >= 0.4.2.0 && < 0.6, + transformers >= 0.5 && < 0.7, + transformers-base >= 0.4.5.2 && < 0.5, + template-haskell >= 2.11 && < 2.21 - if impl(ghc) - cpp-options: -DGHC_TYPEABLE + if !impl(ghc >= 8.2) + build-depends: bifunctor-classes-compat >= 0.1 && < 0.2 exposed-modules: Control.Applicative.Free + Control.Applicative.Free.Fast + 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 + Control.Comonad.Trans.Coiter Control.Monad.Free + Control.Monad.Free.Ap Control.Monad.Free.Church Control.Monad.Free.Class + Control.Monad.Free.TH Control.Monad.Trans.Free - Control.MonadPlus.Free - Control.Comonad.Cofree - Control.Comonad.Cofree.Class - Control.Comonad.Trans.Cofree + Control.Monad.Trans.Free.Ap + Control.Monad.Trans.Free.Church + Control.Monad.Trans.Iter - ghc-options: -Wall + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances + + if !impl(ghc >= 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + x-docspec-extra-packages: tagged diff --git a/src/Control/Alternative/Free.hs b/src/Control/Alternative/Free.hs --- a/src/Control/Alternative/Free.hs +++ b/src/Control/Alternative/Free.hs @@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Alternative.Free @@ -20,6 +19,7 @@ ---------------------------------------------------------------------------- module Control.Alternative.Free ( Alt(..) + , AltF(..) , runAlt , liftAlt , hoistAlt @@ -27,50 +27,81 @@ import Control.Applicative import Data.Functor.Apply -import Data.Semigroup +import Data.Functor.Alt (()) +import qualified Data.Functor.Alt as Alt -#ifdef GHC_TYPEABLE -import Data.Typeable +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup #endif --- | The free 'Alternative' 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 -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable) -#endif +infixl 3 `Ap` --- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' 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 +data AltF f a where + Ap :: f a -> Alt f (a -> b) -> AltF f b + Pure :: a -> AltF f a +newtype Alt f a = Alt { alternatives :: [AltF f a] } + +instance Functor (AltF f) where + fmap f (Pure a) = Pure $ f a + fmap f (Ap x g) = x `Ap` fmap (f .) g + 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) + fmap f (Alt xs) = Alt $ map (fmap f) xs -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 (AltF f) where + pure = Pure + {-# INLINE pure #-} + (Pure f) <*> y = fmap f y -- fmap + y <*> (Pure a) = fmap ($ a) y -- interchange + (Ap a f) <*> b = a `Ap` (flip <$> f <*> (Alt [b])) + {-# INLINE (<*>) #-} 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' + pure a = Alt [pure a] + {-# INLINE pure #-} + (Alt xs) <*> ys = Alt (xs >>= alternatives . (`ap'` ys)) + where + ap' :: AltF f (a -> b) -> Alt f a -> Alt f b + + Pure f `ap'` u = fmap f u + (u `Ap` f) `ap'` v = Alt [u `Ap` (flip <$> f) <*> v] + {-# INLINE (<*>) #-} + +liftAltF :: f a -> AltF f a +liftAltF x = x `Ap` pure id +{-# INLINE liftAltF #-} + +-- | A version of 'lift' that can be used with any @f@. +liftAlt :: f a -> Alt f a +liftAlt = Alt . (:[]) . liftAltF +{-# INLINE liftAlt #-} + +-- | 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 u xs0 = go xs0 where + + go :: Alt f b -> g b + go (Alt xs) = foldr (\r a -> (go2 r) <|> a) empty xs + + go2 :: AltF f b -> g b + go2 (Pure a) = pure a + go2 (Ap x f) = flip id <$> u x <*> go f +{-# INLINABLE runAlt #-} + +instance Apply (Alt f) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Alt.Alt (Alt f) where + () = (<|>) + {-# INLINE () #-} + 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 @@ -80,39 +111,17 @@ instance Monoid (Alt f a) where mempty = empty {-# INLINE mempty #-} - mappend = (<|>) + mappend = (<>) {-# INLINE mappend #-} - mconcat as = fromList (as >>= toList) - where - toList (Alt xs) = xs - toList x = [x] - fromList [x] = x - fromList xs = Alt xs + mconcat as = Alt (as >>= alternatives) {-# 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 #-} +hoistAltF :: (forall a. f a -> g a) -> AltF f b -> AltF g b +hoistAltF _ (Pure a) = Pure a +hoistAltF f (Ap x y) = Ap (f x) (hoistAlt f y) +{-# INLINE hoistAltF #-} -- | 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 _ (Pure a) = Pure a -hoistAlt f (Ap x y) = Ap (f x) (hoistAlt f y) -hoistAlt f (Alt as) = Alt (map (hoistAlt f) as) - -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -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 +hoistAlt f (Alt as) = Alt (map (hoistAltF f) as) +{-# INLINE hoistAlt #-} diff --git a/src/Control/Alternative/Free/Final.hs b/src/Control/Alternative/Free/Final.hs new file mode 100644 --- /dev/null +++ b/src/Control/Alternative/Free/Final.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +-- | The free 'Alternative' for any @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) + some (Alt x) = Alt $ \k -> some (x k) + many (Alt x) = Alt $ \k -> many (x 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 --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -1,14 +1,11 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Free --- Copyright : (C) 2012 Edward Kmett +-- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -18,32 +15,58 @@ -- 'Applicative' functors for free ---------------------------------------------------------------------------- module Control.Applicative.Free - ( Ap(..) + ( + -- | 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. + -- + -- See , + -- by Paolo Capriotti and Ambrus Kaposi, for some applications. + + Ap(..) , runAp + , runAp_ , liftAp + , iterAp , hoistAp + , retractAp + + -- * Examples + -- $examples ) where import Control.Applicative +import Control.Comonad (Comonad(..)) import Data.Functor.Apply +import Data.Foldable +import Data.Semigroup.Foldable +import Data.Functor.Classes -#ifdef GHC_TYPEABLE -import Data.Typeable -#endif +import Prelude hiding (null) -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where Pure :: a -> Ap f a Ap :: f a -> Ap f (a -> b) -> Ap f b -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable) -#endif -- | 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 _ (Pure x) = pure x runAp u (Ap f x) = flip id <$> u f <*> runAp u x +-- | 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 (Pure a) = Pure (f a) fmap f (Ap x y) = Ap x ((f .) <$> y) @@ -57,28 +80,252 @@ Pure f <*> y = fmap f y Ap x y <*> z = Ap x (flip <$> y <*> z) +instance Comonad f => Comonad (Ap f) where + extract (Pure a) = a + extract (Ap x y) = extract y (extract x) + duplicate (Pure a) = Pure (Pure a) + duplicate (Ap x y) = Ap (duplicate x) (extend (flip Ap) y) + +-- | @foldMap f == foldMap f . 'runAp' 'Data.Foldable.toList'@ +instance Foldable f => Foldable (Ap f) where + foldMap f (Pure a) = f a + foldMap f (Ap x y) = foldMap (\a -> foldMap (\g -> f (g a)) y) x + + null (Pure _) = False + null (Ap x y) = null x || null y + + length = go 1 + where + -- This type annotation is required to do polymorphic recursion + go :: Foldable t => Int -> Ap t a -> Int + go n (Pure _) = n + go n (Ap x y) = case n * length x of + 0 -> 0 + n' -> go n' y + +-- | @foldMap f == foldMap f . 'runAp' 'toNonEmpty'@ +instance Foldable1 f => Foldable1 (Ap f) where + foldMap1 f (Pure a) = f a + foldMap1 f (Ap x y) = foldMap1 (\a -> foldMap1 (\g -> f (g a)) y) x + + +{- $note_eq1 + +This comment section is an internal documentation, but written in proper +Haddock markup. It is to allow rendering them to ease reading this rather long document. + +=== About the definition of @Eq1 (Ap f)@ instance + +The @Eq1 (Ap f)@ instance below has a complex definition. This comment +explains why it is defined like that. + +The discussion given here also applies to @Ord1 (Ap f)@ instance with a little change. + +==== General discussion about @Eq1@ type class + +Currently, there isn't a law on the @Eq1@ type class, but the following +properties can be expected. + +* If @Eq (f ())@, and @Functor f@ holds, @Eq1 f@ satisfies + + > liftEq (\_ _ -> True) x y == (() <$ x) == (() <$ y) + +* If @Foldable f@ holds, @Eq1 f@ satisfies: + + * @boringEq x y@ implies @length (toList x) == length (toList y)@ + + * @liftEq eq x y == liftEq (\_ _ -> True) && all (\(a,b) -> eq a b)) (zip (toList x) (toList y))@ + +Let's define the commonly used function @liftEq (\\_ _ -> True)@ as @boringEq@. + +> boringEq :: Eq1 f => f a -> f b -> Bool +> boringEq = liftEq (\_ _ -> True) + +Changing the constant @True@ to the constant @False@ in the definition of +@boringEq@, let @emptyEq@ function be defined as: + +> emptyEq :: Eq1 f => f a -> f b -> Bool +> emptyEq = liftEq (\_ _ -> False) + +From the above properties expectated on a @Eq1@ instance, @emptyEq@ satisfies the following. + +> emptyEq x y = boringEq x y && null (zip (toList x) (toList y)) + +==== About @instance (Eq1 (Ap f))@ + +If we're to define @Eq1 (Ap f)@ satisfying these properties as expected, @Eq (Ap f ())@ will determine +how @liftEq@ should behave. It's not unreasonable to define equality between @Ap f ()@ as below. + +> boringEqAp (Pure _) (Pure _) = True +> boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2 +> {- = ((() <$ x1) == (() <$ x2)) && (y1 == y2) -} +> boringEqAp _ _ = False + +Its type can be more general than equality between @Ap f ()@: + +> boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool + +Using @boringEqAp@, the specification of @liftEq@ will be: + +> liftEq eq x y = boringEqAp x y && and (zipWith eq (toList x) (toList y)) + +Then unfold @toList@ to remove the dependency to @Foldable@. + +> liftEq eq (Pure a1) (Pure a2) +> = boringEqAp (Pure a1) (Pure a2) && all (\(a,b) -> eq a b)) (zip (toList (Pure x)) (toList Pure y)) +> = True && all (\(a,b) -> eq a b) (zip [a1] [a2]) +> = eq a1 a2 +> liftEq eq (Ap x1 y1) (Ap x2 y2) +> = boringEqAp (Ap x1 y1) (Ap x2 y2) && all (\(b1, b2) -> eq b1 b2) (zip (toList (Ap x1 y1)) (toList (Ap x2 y2))) +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (toList x1 <**> toList y1) (toList x2 <**> toList y2)) +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (as1 <**> gs1) (as2 <**> gs2)) +> where as1 = toList x1 +> as2 = toList x2 +> gs1 = toList y1 +> gs2 = toList y2 +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) + +If @zip as1 as2@ is /not/ empty, the following transformation is valid. + +> (...) | not (null (zip as1 as2)) +> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> = boringEq x1 x2 && all (\(a1, a2) -> boringEqAp y1 y2 && all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +> = boringEq x1 x2 && all (\(a1, a2) -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) (zip as1 as2) +> = liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 + +Because, generally, the following transformation is valid if @xs@ is a nonempty list. + +> cond && all p xs = all (\x -> cond && p x) xs -- Only when xs is not empty! + +If @zip as1 as2@ is empty, @all (...) (zip as1 as2)@ is vacuously true, so the following transformation is valid. + +> (...) | null (zip as1 as2) +> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> = boringEq x1 x2 && boringEqAp y1 y2 + +Combining two cases: + +> liftEq eq (Ap x1 y1) (Ap x2 y2) +> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2 +> || not (null (zip as1 as2)) && liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 +> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2 +> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 +> = emptyEq x1 x2 && boringEqAp y1 y2 +> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 + +The property about @emptyEq@ is used in the last equation. + +Hence it's defined as this source code. + +-} + +-- | Specialized 'boringEq' for @Ap f@. +boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool +boringEqAp (Pure _) (Pure _) = True +boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2 +boringEqAp _ _ = False + +-- | Implementaion of 'liftEq' for @Ap f@. +liftEqAp :: Eq1 f => (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool +liftEqAp eq (Pure a1) (Pure a2) = eq a1 a2 +liftEqAp eq (Ap x1 y1) (Ap x2 y2) + -- This branching is necessary and not just an optimization. + -- See the above comment for more + | emptyEq x1 x2 = boringEqAp y1 y2 + | otherwise = + liftEq (\a1 a2 -> liftEqAp (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) x1 x2 +liftEqAp _ _ _ = False + +-- | @boringEq fa fb@ tests if @fa@ and @fb@ are equal ignoring any difference between +-- their content (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'boring\' because the type parameters @a@ and @b@ are +-- treated as if they are the most boring type @()@. +boringEq :: Eq1 f => f a -> f b -> Bool +boringEq = liftEq (\_ _ -> True) + +-- | @emptyEq fa fb@ tests if @fa@ and @fb@ are equal /and/ they don't have any content +-- (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'empty\' because it only tests for values without any content, +-- like an empty list or @Nothing@. +-- +-- If @f@ is also @Foldable@, @emptyEq fa fb@ would be equivalent to +-- @null fa && null fb && liftEq eq@ for any @eq :: a -> b -> Bool@. +-- +-- (It depends on each instance of @Eq1@. Since @Eq1@ does not have +-- any laws currently, this is not a hard guarantee. But all instances in "base", "transformers", +-- "containers", "array", and "free" satisfy it.) +-- +-- Note that @emptyEq@ is not a equivalence relation, since it's possible @emptyEq x x == False@. +emptyEq :: Eq1 f => f a -> f b -> Bool +emptyEq = liftEq (\_ _ -> False) + +instance Eq1 f => Eq1 (Ap f) where + liftEq = liftEqAp + +instance (Eq1 f, Eq a) => Eq (Ap f a) where + (==) = eq1 + +-- | Specialized 'boringCompare' for @Ap f@. +boringCompareAp :: Ord1 f => Ap f a -> Ap f b -> Ordering +boringCompareAp (Pure _) (Pure _) = EQ +boringCompareAp (Pure _) (Ap _ _) = LT +boringCompareAp (Ap x1 y1) (Ap x2 y2) = boringCompare x1 x2 `mappend` boringCompareAp y1 y2 +boringCompareAp (Ap _ _) (Pure _) = GT + +-- | Implementation of 'liftCompare' for @Ap f@ +liftCompareAp :: Ord1 f => (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering +liftCompareAp cmp (Pure a1) (Pure a2) = cmp a1 a2 +liftCompareAp _ (Pure _) (Ap _ _) = LT +liftCompareAp cmp (Ap x1 y1) (Ap x2 y2) + -- This branching is necessary and not just an optimization. + -- See the above comment for more + | emptyEq x1 x2 = boringCompareAp y1 y2 + | otherwise = liftCompare (\a1 a2 -> liftCompareAp (\g1 g2 -> cmp (g1 a1) (g2 a2)) y1 y2) x1 x2 +liftCompareAp _ (Ap _ _) (Pure _) = GT + +-- | @boringCompare fa fb@ compares @fa@ and @fb@ ignoring any difference between +-- their content (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'boring\' because the type parameters @a@ and @b@ are +-- treated as if they are the most boring type @()@. +boringCompare :: Ord1 f => f a -> f b -> Ordering +boringCompare = liftCompare (\_ _ -> EQ) + +instance Ord1 f => Ord1 (Ap f) where + liftCompare = liftCompareAp + +instance (Ord1 f, Ord a) => Ord (Ap f a) where + compare = compare1 + -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftAp :: f a -> Ap f a liftAp x = Ap x (Pure id) {-# INLINE liftAp #-} +-- | Tear down a free 'Applicative' using iteration. +iterAp :: Functor g => (g a -> a) -> Ap g a -> a +iterAp algebra = go + where go (Pure a) = a + go (Ap underlying apply) = algebra (go . (apply <*>) . pure <$> underlying) + -- | 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 _ (Pure a) = Pure a hoistAp f (Ap x y) = Ap (f x) (hoistAp f y) -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -instance Typeable1 f => Typeable1 (Ap f) where - typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where - f :: Ap f a -> f a - f = undefined +-- | 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 (Pure a) = pure a +retractAp (Ap x y) = x <**> retractAp y -apTyCon :: TyCon -#if __GLASGOW_HASKELL__ < 704 -apTyCon = mkTyCon "Control.Applicative.Free.Ap" -#else -apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap" -#endif -{-# NOINLINE apTyCon #-} +{- $examples -#endif + + +-} diff --git a/src/Control/Applicative/Free/Fast.hs b/src/Control/Applicative/Free/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Free/Fast.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- +-- | +-- A faster free applicative. +-- Based on . +-------------------------------------------------------------------------------- +module Control.Applicative.Free.Fast + ( + -- * The Sequence of Effects + ASeq(..) + , reduceASeq + , hoistASeq + , traverseASeq + , rebaseASeq + -- * The Faster Free Applicative + , Ap(..) + , liftAp + , retractAp + , runAp + , runAp_ + , hoistAp + ) where + +import Control.Applicative +import Data.Functor.Apply + +-- | The free applicative is composed of a sequence of effects, +-- and a pure function to apply that sequence to. +-- The fast free applicative separates these from each other, +-- so that the sequence may be built up independently, +-- and so that 'fmap' can run in constant time by having immediate access to the pure function. +data ASeq f a where + ANil :: ASeq f () + ACons :: f a -> ASeq f u -> ASeq f (a,u) + +-- | Interprets the sequence of effects using the semantics for +-- `pure` and `<*>` given by the Applicative instance for 'f'. +reduceASeq :: Applicative f => ASeq f u -> f u +reduceASeq ANil = pure () +reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs + +-- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@. +hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a +hoistASeq _ ANil = ANil +hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs) + +-- | Traverse a sequence with resepect to its interpretation type 'f'. +traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a) +traverseASeq _ ANil = pure ANil +traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f xs + +-- | It may not be obvious, but this essentially acts like ++, +-- traversing the first sequence and creating a new one by appending the second sequence. +-- The difference is that this also has to modify the return functions and that the return type depends on the input types. +-- +-- See the source of 'hoistAp' as an example usage. +rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) -> + (v -> u -> y) -> ASeq f v -> z +rebaseASeq ANil k f = k (\v -> f v ()) +rebaseASeq (ACons x xs) k f = + rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s)) + (\v u a -> f v (a,u)) + + +-- | The faster free 'Applicative'. +newtype Ap f a = Ap + { unAp :: forall u y z. + (forall x. (x -> y) -> ASeq f x -> z) -> + (u -> a -> y) -> ASeq f u -> z } + +-- | 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 u = retractAp . hoistAp u + +-- | 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 g x = Ap (\k f -> unAp x k (\s -> f s . g)) + +instance Apply (Ap f) where + (<.>) = (<*>) + +instance Applicative (Ap f) where + pure a = Ap (\k f -> k (`f` a)) + x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a))) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s)) +{-# INLINE liftAp #-} + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a +hoistAp g x = Ap (\k f s -> + unAp x + (\f' s' -> + rebaseASeq (hoistASeq g s') k + (\v u -> f v (f' u)) s) + (const id) + ANil) + +-- | 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 x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil diff --git a/src/Control/Applicative/Free/Final.hs b/src/Control/Applicative/Free/Final.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Free/Final.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + +-- | 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 --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Trans/Free.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Trans.Free +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- 'Applicative' functor transformers for free +---------------------------------------------------------------------------- +module Control.Applicative.Trans.Free + ( + -- | Compared to the free monad transformers, 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. + -- + -- See , + -- by Paolo Capriotti and Ambrus Kaposi, for some applications. + ApT(..) + , ApF(..) + , liftApT + , liftApO + , runApT + , runApF + , runApT_ + , hoistApT + , hoistApF + , transApT + , transApF + , joinApT + -- * Free Applicative + , Ap + , runAp + , runAp_ + , retractAp + -- * Free Alternative + , Alt + , runAlt + ) where + +import Control.Applicative +import Control.Monad (liftM) +import Data.Functor.Apply +import Data.Functor.Identity + +-- | The free 'Applicative' for a 'Functor' @f@. +data ApF f g a where + Pure :: a -> ApF f g a + Ap :: f a -> ApT f g (a -> b) -> ApF f g b + +-- | The free 'Applicative' transformer for a 'Functor' @f@ over +-- 'Applicative' @g@. +newtype ApT f g a = ApT { getApT :: g (ApF f g a) } + +instance Functor g => Functor (ApF f g) where + fmap f (Pure a) = Pure (f a) + fmap f (Ap x g) = x `Ap` fmap (f .) g + +instance Functor g => Functor (ApT f g) where + fmap f (ApT g) = ApT (fmap f <$> g) + +instance Applicative g => Applicative (ApF f g) where + pure = Pure + {-# INLINE pure #-} + Pure f <*> y = fmap f y -- fmap + y <*> Pure a = fmap ($ a) y -- interchange + Ap a f <*> b = a `Ap` (flip <$> f <*> ApT (pure b)) + {-# INLINE (<*>) #-} + +instance Applicative g => Applicative (ApT f g) where + pure = ApT . pure . pure + {-# INLINE pure #-} + ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys) + {-# INLINE (<*>) #-} + +instance Applicative g => Apply (ApF f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Applicative g => Apply (ApT f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Alternative g => Alternative (ApT f g) where + empty = ApT empty + {-# INLINE empty #-} + ApT g <|> ApT h = ApT (g <|> h) + {-# INLINE (<|>) #-} + +-- | A version of 'lift' that can be used with no constraint for @f@. +liftApT :: Applicative g => f a -> ApT f g a +liftApT x = ApT (pure (Ap x (pure id))) + +-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@. +liftApO :: Functor g => g a -> ApT f g a +liftApO g = ApT (Pure <$> g) + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApF f g ~> h@. +runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b +runApF _ _ (Pure x) = pure x +runApF f g (Ap x y) = f x <**> runApT f g y + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApT f g ~> h@. +runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b +runApT f g (ApT a) = g (runApF f g <$> a) + +-- | Perform a monoidal analysis over @'ApT' f g b@ value. +-- +-- Examples: +-- +-- @ +-- height :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int' +-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'maximum' +-- @ +-- +-- @ +-- size :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int' +-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'fold' +-- @ +runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m +runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst) + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@. +hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b +hoistApF _ (Pure x) = Pure x +hoistApF f (Ap x y) = f x `Ap` hoistApT f y + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@. +hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b +hoistApT f (ApT g) = ApT (hoistApF f <$> g) + +-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@. +transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b +transApF _ (Pure x) = Pure x +transApF f (Ap x y) = x `Ap` transApT f y + +-- | 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 + +-- | 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 f = runApT f runIdentity + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: 'Ap' f a -> 'Int' +-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1) +-- @ +runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m +runAp_ f = runApT_ f runIdentity + +-- | 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 = runAp id + +-- | The free 'Alternative' for a 'Functor' @f@. +type Alt f = ApT f [] + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. +runAlt :: (Alternative g, Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a +runAlt f (ApT xs) = foldr (\x acc -> h x <|> acc) empty xs + where + h (Pure x) = pure x + h (Ap x g) = f x <**> runAlt f g diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs --- a/src/Control/Comonad/Cofree.hs +++ b/src/Control/Comonad/Cofree.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree --- Copyright : (C) 2008-2012 Edward Kmett +-- Copyright : (C) 2008-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -24,11 +25,17 @@ , ComonadCofree(..) , section , coiter + , coiterW , unfold + , unfoldM + , hoistCofree -- * Lenses into cofree comonads , _extract , _unwrap , telescoped + , telescoped_ + , shoots + , leaves ) where import Control.Applicative @@ -38,20 +45,26 @@ import Control.Comonad.Env.Class import Control.Comonad.Store.Class as Class import Control.Comonad.Traced.Class +import Control.Comonad.Hoist.Class import Control.Category +import Control.Monad(ap, (>=>), liftM) +import Control.Monad.Zip import Data.Functor.Bind +import Data.Functor.Classes import Data.Functor.Extend +import Data.Functor.WithIndex +import Data.Data import Data.Distributive import Data.Foldable +import Data.Foldable.WithIndex import Data.Semigroup import Data.Traversable +import Data.Traversable.WithIndex import Data.Semigroup.Foldable import Data.Semigroup.Traversable +import GHC.Generics hiding (Infix, Prefix) import Prelude hiding (id,(.)) -#ifdef GHC_TYPEABLE -import Data.Data -#endif infixr 5 :< @@ -60,7 +73,7 @@ -- /Formally/ -- -- A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every comonad homomorphism --- another comonad @w@ to @v@ is equivalent to a natural transformation +-- from another comonad @w@ to @v@ is equivalent to a natural transformation -- from @w@ to @f@. -- -- A 'cofree' functor is right adjoint to a forgetful functor. @@ -77,7 +90,7 @@ -- -- For instance, -- --- * @'Cofree' 'Maybe'@ forms the a comonad for a non-empty list. +-- * @'Cofree' 'Maybe'@ forms the comonad for a non-empty list. -- -- * @'Cofree' ('Const' b)@ is a product. -- @@ -85,22 +98,43 @@ -- -- * @'Cofree' ((->) b)'@ describes a Moore machine with states labeled with values of type a, and transitions on edges of type b. -- +-- Furthermore, if the functor @f@ forms a monoid (for example, by +-- being an instance of 'Alternative'), the resulting 'Comonad' is +-- also a 'Monad'. See +-- by Neil Ghani et al., Section 4.3 +-- for more details. +-- +-- In particular, if @f a ≡ [a]@, the +-- resulting data structure is a . +-- For a practical application, check +-- by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a) -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable) -#endif + deriving (Generic, Generic1) +deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a) + -- | Use coiteration to generate a cofree comonad from a seed. -- -- @'coiter' f = 'unfold' ('id' 'Control.Arrow.&&&' f)@ coiter :: Functor f => (a -> f a) -> a -> Cofree f a coiter psi a = a :< (coiter psi <$> psi a) +-- | Like coiter for comonadic values. +coiterW :: (Comonad w, Functor f) => (w a -> f (w a)) -> w a -> Cofree f a +coiterW psi a = extract a :< (coiterW psi <$> psi a) + -- | Unfold a cofree comonad from a seed. 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) + instance Functor f => ComonadCofree f (Cofree f) where unwrap (_ :< as) = as {-# INLINE unwrap #-} @@ -130,11 +164,14 @@ {-# INLINE lower #-} instance Alternative f => Monad (Cofree f) where - return x = x :< empty + return = pure {-# INLINE return #-} (a :< m) >>= k = case k a of b :< n -> b :< (n <|> fmap (>>= k) m) +instance (Alternative f, MonadZip f) => MonadZip (Cofree f) where + mzip (a :< as) (b :< bs) = (a, b) :< fmap (uncurry mzip) (mzip as bs) + -- | -- -- @'lower' . 'section' = 'id'@ @@ -157,39 +194,57 @@ (_ :< 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) +instance Alternative f => Applicative (Cofree f) where + pure x = x :< empty + {-# INLINE pure #-} + (<*>) = ap {-# 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) $ - showsPrec 6 a . showString " :< " . showsPrec 5 as +instance (Show1 f) => Show1 (Cofree f) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (a :< as) = showParen (d > 5) $ + sp 6 a . showString " :< " . liftShowsPrec go goList 5 as -instance (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where - readsPrec d r = readParen (d > 5) - (\r' -> [(u :< v,w) | - (u, s) <- readsPrec 6 r', - (":<", t) <- lex s, - (v, w) <- readsPrec 5 t]) r +instance (Show1 f, Show a) => Show (Cofree f a) where + showsPrec = showsPrec1 -instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where - a :< as == b :< bs = a == b && as == bs +instance (Read1 f) => Read1 (Cofree f) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go d r = readParen (d > 5) + (\r' -> [(u :< v, w) | + (u, s) <- rp 6 r', + (":<", t) <- lex s, + (v, w) <- liftReadsPrec go goList 5 t]) r -instance (Ord (f (Cofree f a)), Ord a) => Ord (Cofree f a) where - compare (a :< as) (b :< bs) = case compare a b of - LT -> LT - EQ -> compare as bs - GT -> GT +instance (Read1 f, Read a) => Read (Cofree f a) where + readsPrec = readsPrec1 +instance (Eq1 f, Eq a) => Eq (Cofree f a) where + (==) = eq1 + +instance (Eq1 f) => Eq1 (Cofree f) where + liftEq eq = go + where + go (a :< as) (b :< bs) = eq a b && liftEq go as bs + +instance (Ord1 f, Ord a) => Ord (Cofree f a) where + compare = compare1 + +instance (Ord1 f) => Ord1 (Cofree f) where + liftCompare cmp = go + where + go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs + instance Foldable f => Foldable (Cofree f) where foldMap f = go where go (a :< as) = f a `mappend` foldMap go as {-# INLINE foldMap #-} + length = go 0 where + go s (_ :< as) = foldl' go (s + 1) as instance Foldable1 f => Foldable1 (Cofree f) where foldMap1 f = go where @@ -206,45 +261,20 @@ go (a :< as) = (:<) <$> f a <.> traverse1 go as {-# INLINE traverse1 #-} -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -instance (Typeable1 f) => Typeable1 (Cofree f) where - typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)] - where - f :: Cofree f a -> f a - f = undefined - -instance (Typeable1 f, Typeable a) => Typeable (Cofree f a) where - typeOf = typeOfDefault - -cofreeTyCon :: TyCon -#if __GLASGOW_HASKELL__ < 704 -cofreeTyCon = mkTyCon "Control.Comonad.Cofree.Cofree" -#else -cofreeTyCon = mkTyCon3 "free" "Control.Comonad.Cofree" "Cofree" -#endif -{-# NOINLINE cofreeTyCon #-} +instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where + imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as + {-# INLINE imap #-} -instance - ( Typeable1 f - , Data (f (Cofree f a)) - , Data a - ) => Data (Cofree f a) where - gfoldl f z (a :< as) = z (:<) `f` a `f` as - toConstr _ = cofreeConstr - gunfold k z c = case constrIndex c of - 1 -> k (k (z (:<))) - _ -> error "gunfold" - dataTypeOf _ = cofreeDataType - dataCast1 f = gcast1 f +instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where + ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as + {-# INLINE ifoldMap #-} -cofreeConstr :: Constr -cofreeConstr = mkConstr cofreeDataType ":<" [] Infix -{-# NOINLINE cofreeConstr #-} +instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where + itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as + {-# INLINE itraverse #-} -cofreeDataType :: DataType -cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr] -{-# NOINLINE cofreeDataType #-} -#endif +instance ComonadHoist Cofree where + cohoist = hoistCofree instance ComonadEnv e w => ComonadEnv e (Cofree w) where ask = ask . lower @@ -286,13 +316,85 @@ _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. +-- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor. +-- When the input list is empty, this is equivalent to '_extract'. +-- When the input list is non-empty, this composes the input lenses +-- with '_unwrap' to walk through the @'Cofree' g@ before using +-- '_extract' to get the element at the final location. -- -- For more on lenses see the 'lens' package on hackage. -- --- @telescoped :: 'Functor' g => [Lens' ('Cofree' g a) (g ('Cofree' g a))] -> Lens' ('Cofree' g a) a@ -telescoped :: (Functor f, Functor g) => +-- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)] -> Lens' ('Cofree' g a) a@ +-- +-- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) a@ +-- +-- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)] -> Getter ('Cofree' g a) a@ +-- +-- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)] -> Fold ('Cofree' g a) a@ +-- +-- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)] -> Setter' ('Cofree' g a) a@ +telescoped :: Functor f => [(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 = Prelude.foldr (\l r -> _unwrap . l . r) _extract {-# INLINE telescoped #-} + +-- not actually named 'eats' +-- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor. +-- The only difference between this and 'telescoped' is that 'telescoped' focuses on a single value, but this focuses on the entire remaining subtree. +-- When the input list is empty, this is equivalent to 'id'. +-- When the input list is non-empty, this composes the input lenses +-- with '_unwrap' to walk through the @'Cofree' g@. +-- +-- For more on lenses see the 'lens' package on hackage. +-- +-- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)] -> Lens' ('Cofree' g a) ('Cofree' g a)@ +-- +-- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) ('Cofree' g a)@ +-- +-- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)] -> Getter ('Cofree' g a) ('Cofree' g a)@ +-- +-- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)] -> Fold ('Cofree' g a) ('Cofree' g a)@ +-- +-- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)] -> Setter' ('Cofree' g a) ('Cofree' g a)@ +telescoped_ :: Functor f => + [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] -> + (Cofree g a -> f (Cofree g a)) -> Cofree g a -> f (Cofree g a) +telescoped_ = Prelude.foldr (\l r -> _unwrap . l . r) id +{-# INLINE telescoped_ #-} + +-- | A @Traversal'@ that gives access to all non-leaf @a@ elements of a +-- @'Cofree' g@ a, where non-leaf is defined as @x@ from @(x :< xs)@ where +-- @null xs@ is @False@. +-- +-- Because this doesn't give access to all values in the @'Cofree' g@, +-- it cannot be used to change types. +-- +-- @shoots :: Traversable g => Traversal' (Cofree g a) a@ +-- +-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to +-- use @null (toList xs)@ instead. +shoots :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a) +shoots f = go + where + go xxs@(x :< xs) | null xs = pure xxs + | otherwise = (:<) <$> f x <*> traverse go xs +{-# INLINE shoots #-} + +-- | A @Traversal'@ that gives access to all leaf @a@ elements of a +-- @'Cofree' g@ a, where leaf is defined as @x@ from @(x :< xs)@ where +-- @null xs@ is @True@. +-- +-- Because this doesn't give access to all values in the @'Cofree' g@, +-- it cannot be used to change types. +-- +-- @shoots :: Traversable g => Traversal' (Cofree g a) a@ +-- +-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to +-- use @null (toList xs)@ instead. +leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a) +leaves f = go + where + go (x :< xs) | null xs = (:< xs) <$> f x + | otherwise = (x :<) <$> traverse go xs +{-# INLINE leaves #-} diff --git a/src/Control/Comonad/Cofree/Class.hs b/src/Control/Comonad/Cofree/Class.hs --- a/src/Control/Comonad/Cofree/Class.hs +++ b/src/Control/Comonad/Cofree/Class.hs @@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree.Class @@ -22,13 +24,24 @@ import Control.Comonad.Trans.Store import Control.Comonad.Trans.Traced import Control.Comonad.Trans.Identity -import Data.Semigroup +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Tree -- | Allows you to peel a layer off a cofree comonad. class (Functor f, Comonad w) => ComonadCofree f w | w -> f where -- | Remove a layer. unwrap :: w a -> f (w a) +instance ComonadCofree Maybe NonEmpty where + unwrap (_ :| []) = Nothing + unwrap (_ :| (a : as)) = Just (a :| as) + +instance ComonadCofree [] Tree where + unwrap = subForest + +instance ComonadCofree (Const b) ((,) b) where + unwrap = Const . fst + instance ComonadCofree f w => ComonadCofree f (IdentityT w) where unwrap = fmap IdentityT . unwrap . runIdentityT @@ -38,5 +51,5 @@ instance ComonadCofree f w => ComonadCofree f (StoreT s w) where unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa -instance (ComonadCofree f w, Semigroup m, Monoid m) => ComonadCofree f (TracedT m w) where +instance (ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where unwrap (TracedT wma) = TracedT <$> unwrap wma diff --git a/src/Control/Comonad/Trans/Cofree.hs b/src/Control/Comonad/Trans/Cofree.hs --- a/src/Control/Comonad/Trans/Cofree.hs +++ b/src/Control/Comonad/Trans/Cofree.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Trans.Cofree --- Copyright : (C) 2008-2012 Edward Kmett +-- Copyright : (C) 2008-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -21,10 +21,12 @@ ---------------------------------------------------------------------------- module Control.Comonad.Trans.Cofree ( CofreeT(..) + , Cofree, cofree, runCofree , CofreeF(..) , ComonadCofree(..) , headF , tailF + , transCofreeT , coiterT ) where @@ -32,29 +34,65 @@ import Control.Comonad import Control.Comonad.Trans.Class import Control.Comonad.Cofree.Class +import Control.Comonad.Env.Class +import Control.Comonad.Hoist.Class import Control.Category import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Foldable -import Data.Semigroup +import Data.Functor.Classes +import Data.Functor.Identity import Data.Traversable +import Control.Monad (liftM) +import Control.Monad.Trans +import Control.Monad.Zip import Prelude hiding (id,(.)) - -#if defined(GHC_TYPEABLE) || __GLASGOW_HASKELL__ >= 707 import Data.Data -#endif +import GHC.Generics hiding (Infix, Prefix) infixr 5 :< -- | This is the base functor of the cofree comonad transformer. data CofreeF f a b = a :< f b - deriving (Eq,Ord,Show,Read -#if __GLASGOW_HASKELL__ >= 707 - ,Typeable -#endif - ) + deriving (Eq,Ord,Show,Read,Generic,Generic1) +instance Show1 f => Show2 (CofreeF f) where + liftShowsPrec2 spa _sla spb slb d (a :< fb) = + showParen (d > 5) $ + spa 6 a . showString " :< " . liftShowsPrec spb slb 6 fb + +instance (Show1 f, Show a) => Show1 (CofreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (CofreeF f) where + liftReadsPrec2 rpa _rla rpb rlb d = + readParen (d > 5) $ + (\r' -> [ (u :< v, w) + | (u, s) <- rpa 6 r' + , (":<", t) <- lex s + , (v, w) <- liftReadsPrec rpb rlb 6 t + ]) + +instance (Read1 f, Read a) => Read1 (CofreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (CofreeF f) where + liftEq2 eqa eqfb (a :< fb) (a' :< fb') = eqa a a' && liftEq eqfb fb fb' + +instance (Eq1 f, Eq a) => Eq1 (CofreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (CofreeF f) where + liftCompare2 cmpa cmpfb (a :< fb) (a' :< fb') = + case cmpa a a' of + LT -> LT + EQ -> liftCompare cmpfb fb fb' + GT -> GT + +instance (Ord1 f, Ord a) => Ord1 (CofreeF f a) where + liftCompare = liftCompare2 compare + -- | Extract the head of the base functor headF :: CofreeF f a b -> a headF (a :< _) = a @@ -81,9 +119,43 @@ instance Traversable f => Bitraversable (CofreeF f) where bitraverse f g (a :< as) = (:<) <$> f a <*> traverse g as +transCofreeF :: (forall x. f x -> g x) -> CofreeF f a b -> CofreeF g a b +transCofreeF t (a :< fb) = a :< t fb +{-# INLINE transCofreeF #-} + -- | This is a cofree comonad of some functor @f@, with a comonad @w@ threaded through it at each level. newtype CofreeT f w a = CofreeT { runCofreeT :: w (CofreeF f a (CofreeT f w a)) } +-- | The cofree `Comonad` of a functor @f@. +type Cofree f = CofreeT f Identity + +{- | +Wrap another layer around a cofree comonad value. + +@cofree@ is a right inverse of `runCofree`. + +@ +runCofree . cofree == id +@ +-} +cofree :: CofreeF f a (Cofree f a) -> Cofree f a +cofree = CofreeT . Identity +{-# INLINE cofree #-} + + +{- | +Unpeel the first layer off a cofree comonad value. + +@runCofree@ is a right inverse of `cofree`. + +@ +cofree . runCofree == id +@ +-} +runCofree :: Cofree f a -> CofreeF f a (Cofree f a) +runCofree = runIdentity . runCofreeT +{-# INLINE runCofree #-} + instance (Functor f, Functor w) => Functor (CofreeT f w) where fmap f = CofreeT . fmap (bimap f (fmap f)) . runCofreeT @@ -97,14 +169,21 @@ instance (Traversable f, Traversable w) => Traversable (CofreeT f w) where traverse f = fmap CofreeT . traverse (bitraverse f (traverse f)) . runCofreeT -instance Functor f => ComonadTrans (CofreeT f) where +instance ComonadTrans (CofreeT f) where lower = fmap headF . runCofreeT instance (Functor f, Comonad w) => ComonadCofree f (CofreeT f w) where unwrap = tailF . extract . runCofreeT +instance (Functor f, ComonadEnv e w) => ComonadEnv e (CofreeT f w) where + ask = ask . lower + {-# INLINE ask #-} + +instance Functor f => ComonadHoist (CofreeT f) where + cohoist g = CofreeT . fmap (second (cohoist g)) . g . runCofreeT + instance Show (w (CofreeF f a (CofreeT f w a))) => Show (CofreeT f w a) where - showsPrec d w = showParen (d > 10) $ + showsPrec d (CofreeT w) = showParen (d > 10) $ showString "CofreeT " . showsPrec 11 w instance Read (w (CofreeF f a (CofreeT f w a))) => Read (CofreeT f w a) where @@ -117,72 +196,47 @@ instance Ord (w (CofreeF f a (CofreeT f w a))) => Ord (CofreeT f w a) where compare (CofreeT a) (CofreeT b) = compare a b --- | Unfold a @CofreeT@ comonad transformer from a coalgebra and an initial comonad. -coiterT :: (Functor f, Comonad w) => (w a -> f (w a)) -> w a -> CofreeT f w a -coiterT psi = CofreeT . (extend $ \w -> extract w :< fmap (coiterT psi) (psi w)) +instance (Alternative f, Monad w) => Monad (CofreeT f w) where + CofreeT cx >>= f = CofreeT $ do + a :< m <- cx + b :< n <- runCofreeT $ f a + return $ b :< (n <|> fmap (>>= f) m) -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -instance Typeable1 f => Typeable2 (CofreeF f) where - typeOf2 t = mkTyConApp cofreeFTyCon [typeOf1 (f t)] where - f :: CofreeF f a b -> f a - f = undefined +instance (Alternative f, Applicative w) => Applicative (CofreeT f w) where + pure = CofreeT . pure . (:< empty) + {-# INLINE pure #-} + wf <*> wa = CofreeT $ go <$> runCofreeT wf <*> runCofreeT wa where + go (f :< t) a = case bimap f (fmap f) a of + b :< n -> b :< (n <|> fmap (<*> wa) t) + {-# INLINE (<*>) #-} -instance (Typeable1 f, Typeable1 w) => Typeable1 (CofreeT f w) where - typeOf1 t = mkTyConApp cofreeTTyCon [typeOf1 (f t), typeOf1 (w t)] where - f :: CofreeT f w a -> f a - f = undefined - w :: CofreeT f w a -> w a - w = undefined +instance Alternative f => MonadTrans (CofreeT f) where + lift = CofreeT . liftM (:< empty) -cofreeFTyCon, cofreeTTyCon :: TyCon -#if __GLASGOW_HASKELL__ < 704 -cofreeTTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeT" -cofreeFTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeF" -#else -cofreeTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeT" -cofreeFTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeF" -#endif -{-# NOINLINE cofreeTTyCon #-} -{-# NOINLINE cofreeFTyCon #-} +instance (Alternative f, MonadZip f, MonadZip m) => MonadZip (CofreeT f m) where + mzip (CofreeT ma) (CofreeT mb) = CofreeT $ do + (a :< fa, b :< fb) <- mzip ma mb + return $ (a, b) :< (uncurry mzip <$> mzip fa fb) -instance - ( Typeable1 f, Typeable a, Typeable b +-- | Lift a natural transformation from @f@ to @g@ into a comonad homomorphism from @'CofreeT' f w@ to @'CofreeT' g w@ +transCofreeT :: (Functor g, Comonad w) => (forall x. f x -> g x) -> CofreeT f w a -> CofreeT g w a +transCofreeT t = CofreeT . liftW (fmap (transCofreeT t) . transCofreeF t) . runCofreeT + +-- | Unfold a @CofreeT@ comonad transformer from a coalgebra and an initial comonad. +coiterT :: (Functor f, Comonad w) => (w a -> f (w a)) -> w a -> CofreeT f w a +coiterT psi = CofreeT . extend (\w -> extract w :< fmap (coiterT psi) (psi w)) + +deriving instance + ( Typeable f , Data a, Data (f b), Data b - ) => Data (CofreeF f a b) where - gfoldl f z (a :< as) = z (:<) `f` a `f` as - toConstr _ = cofreeFConstr - gunfold k z c = case constrIndex c of - 1 -> k (k (z (:<))) - _ -> error "gunfold" - dataTypeOf _ = cofreeFDataType - dataCast1 f = gcast1 f + ) => Data (CofreeF f a b) -instance - ( Typeable1 f, Typeable1 w, Typeable a +deriving instance + ( Typeable f, Typeable w , Data (w (CofreeF f a (CofreeT f w a))) , Data a - ) => Data (CofreeT f w a) where - gfoldl f z (CofreeT w) = z CofreeT `f` w - toConstr _ = cofreeTConstr - gunfold k z c = case constrIndex c of - 1 -> k (z CofreeT) - _ -> error "gunfold" - dataTypeOf _ = cofreeTDataType - dataCast1 f = gcast1 f - -cofreeFConstr, cofreeTConstr :: Constr -cofreeFConstr = mkConstr cofreeFDataType ":<" [] Infix -cofreeTConstr = mkConstr cofreeTDataType "CofreeT" [] Prefix -{-# NOINLINE cofreeFConstr #-} -{-# NOINLINE cofreeTConstr #-} - -cofreeFDataType, cofreeTDataType :: DataType -cofreeFDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeF" [cofreeFConstr] -cofreeTDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeT" [cofreeTConstr] -{-# NOINLINE cofreeFDataType #-} -{-# NOINLINE cofreeTDataType #-} -#endif + ) => Data (CofreeT f w a) -- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a -- lowerF = fmap extract . unwrap diff --git a/src/Control/Comonad/Trans/Coiter.hs b/src/Control/Comonad/Trans/Coiter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Trans/Coiter.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Trans.Coiter +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- The coiterative comonad generated by a comonad +---------------------------------------------------------------------------- +module Control.Comonad.Trans.Coiter + ( + -- | + -- Coiterative comonads represent non-terminating, productive computations. + -- + -- They are the dual notion of iterative monads. While iterative computations + -- produce no values or eventually terminate with one, coiterative + -- computations constantly produce values and they never terminate. + -- + -- It's simpler form, 'Coiter', is an infinite stream of data. 'CoiterT' + -- extends this so that each step of the computation can be performed in + -- a comonadic context. + + -- * The coiterative comonad transformer + CoiterT(..) + -- * The coiterative comonad + , Coiter, coiter, runCoiter + -- * Generating coiterative comonads + , unfold + -- * Cofree comonads + , ComonadCofree(..) + -- * Examples + -- $example + ) where + +import Control.Arrow hiding (second) +import Control.Comonad +import Control.Comonad.Cofree.Class +import Control.Comonad.Env.Class +import Control.Comonad.Hoist.Class +import Control.Comonad.Store.Class +import Control.Comonad.Traced.Class +import Control.Comonad.Trans.Class +import Control.Category +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +import Data.Foldable +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Traversable +import Prelude hiding (id,(.)) + +-- | This is the coiterative comonad generated by a comonad +newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) } + +instance (Eq1 w) => Eq1 (CoiterT w) where + liftEq eq = go + where + go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 w) => Ord1 (CoiterT w) where + liftCompare cmp = go + where + go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 w) => Show1 (CoiterT w) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (CoiterT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "CoiterT" d x + +instance (Read1 w) => Read1 (CoiterT w) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "CoiterT" CoiterT + +-- | The coiterative comonad +type Coiter = CoiterT Identity + +-- | Prepends a result to a coiterative computation. +-- +-- prop> runCoiter . uncurry coiter == id +coiter :: a -> Coiter a -> Coiter a +coiter a as = CoiterT $ Identity (a,as) +{-# INLINE coiter #-} + +-- | Extracts the first result from a coiterative computation. +-- +-- prop> uncurry coiter . runCoiter == id +runCoiter :: Coiter a -> (a, Coiter a) +runCoiter = runIdentity . runCoiterT +{-# INLINE runCoiter #-} + +instance Functor w => Functor (CoiterT w) where + fmap f = CoiterT . fmap (bimap f (fmap f)) . runCoiterT + +instance Comonad w => Comonad (CoiterT w) where + extract = fst . extract . runCoiterT + {-# INLINE extract #-} + extend f = CoiterT . extend (\w -> (f (CoiterT w), extend f $ snd $ extract w)) . runCoiterT + +instance Foldable w => Foldable (CoiterT w) where + foldMap f = foldMap (bifoldMap f (foldMap f)) . runCoiterT + +instance Traversable w => Traversable (CoiterT w) where + traverse f = fmap CoiterT . traverse (bitraverse f (traverse f)) . runCoiterT + +instance ComonadTrans CoiterT where + lower = fmap fst . runCoiterT + +instance Comonad w => ComonadCofree Identity (CoiterT w) where + unwrap = Identity . snd . extract . runCoiterT + {-# INLINE unwrap #-} + +instance ComonadEnv e w => ComonadEnv e (CoiterT w) where + ask = ask . lower + {-# INLINE ask #-} + +instance ComonadHoist CoiterT where + cohoist g = CoiterT . fmap (second (cohoist g)) . g . runCoiterT + +instance ComonadTraced m w => ComonadTraced m (CoiterT w) where + trace m = trace m . lower + {-# INLINE trace #-} + +instance ComonadStore s w => ComonadStore s (CoiterT w) where + pos = pos . lower + peek s = peek s . lower + peeks f = peeks f . lower + seek = seek + seeks = seeks + experiment f = experiment f . lower + {-# INLINE pos #-} + {-# INLINE peek #-} + {-# INLINE peeks #-} + {-# INLINE seek #-} + {-# INLINE seeks #-} + {-# INLINE experiment #-} + +instance (Show1 w, Show a) => Show (CoiterT w a) where + showsPrec = showsPrec1 + +instance (Read1 w, Read a) => Read (CoiterT w a) where + readsPrec = readsPrec1 + +instance (Eq1 w, Eq a) => Eq (CoiterT w a) where + (==) = eq1 + {-# INLINE (==) #-} + +instance (Ord1 w, Ord a) => Ord (CoiterT w a) where + compare = compare1 + {-# INLINE compare #-} + +-- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed. +unfold :: Comonad w => (w a -> a) -> w a -> CoiterT w a +unfold psi = CoiterT . extend (extract &&& unfold psi . extend psi) + +deriving instance + ( Typeable w + , Data (w (a, CoiterT w a)) + , Data a + ) => Data (CoiterT w a) + +{- $example + + + +-} diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free --- Copyright : (C) 2008-2012 Edward Kmett +-- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -25,14 +25,23 @@ , retract , liftF , iter + , iterA , iterM , hoistFree + , 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 import Control.Monad.Free.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class @@ -40,16 +49,27 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind +import Data.Functor.Classes +import Data.Functor.WithIndex import Data.Foldable +import Data.Foldable.WithIndex import Data.Profunctor import Data.Traversable +import Data.Traversable.WithIndex import Data.Semigroup.Foldable import Data.Semigroup.Traversable - -#ifdef GHC_TYPEABLE import Data.Data -#endif +import GHC.Generics +import Prelude hiding (foldr) +-- $setup +-- >>> import Control.Applicative (Const (..)) +-- >>> import Data.Functor.Identity (Identity (..)) +-- >>> import Data.Monoid (First (..)) +-- >>> import Data.Tagged (Tagged (..)) +-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x)) +-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x)))) + -- | The 'Free' 'Monad' for a 'Functor' @f@. -- -- /Formally/ @@ -69,7 +89,7 @@ -- -- then 'Free' is the left adjoint to @U@. -- --- Being 'Free' being left adjoint to @U@ means that there is an isomorphism between +-- 'Free' being left adjoint to @U@ means that there is an isomorphism between -- -- @'Free' f -> m@ in the category of monads and @f -> U m@ in the category of functors. -- @@ -86,8 +106,8 @@ -- -- This can be very useful for modeling domain specific languages, trees, or other constructs. -- --- This instance of 'MonadFree' is fairly naive about the encoding. For more efficient free monad implementations that require additional --- extensions and thus aren't included here, you may want to look at the @kan-extensions@ package. +-- This instance of 'MonadFree' is fairly naive about the encoding. For more efficient free monad implementation see "Control.Monad.Free.Church", in particular note the 'Control.Monad.Free.Church.improve' combinator. +-- You may also want to take a look at the @kan-extensions@ package (). -- -- A number of common monads arise as free monads, -- @@ -95,37 +115,50 @@ -- -- * @'Free' 'Maybe'@ can be used to model a partiality monad where each layer represents running the computation for a while longer. data Free f a = Pure a | Free (f (Free f a)) -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable) -#endif + deriving (Generic, Generic1) -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 - _ == _ = False +deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) -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 - Free _ `compare` Pure _ = GT - Free fa `compare` Free fb = fa `compare` fb +instance Eq1 f => Eq1 (Free f) where + liftEq eq = go + where + go (Pure a) (Pure b) = eq a b + go (Free fa) (Free fb) = liftEq go fa fb + go _ _ = False -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 +instance (Eq1 f, Eq a) => Eq (Free f a) where + (==) = eq1 -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 +instance Ord1 f => Ord1 (Free f) where + liftCompare cmp = go + where + go (Pure a) (Pure b) = cmp a b + go (Pure _) (Free _) = LT + go (Free _) (Pure _) = GT + go (Free fa) (Free fb) = liftCompare go fa fb +instance (Ord1 f, Ord a) => Ord (Free f a) where + compare = compare1 + +instance Show1 f => Show1 (Free f) where + liftShowsPrec sp sl = go + where + go d (Pure a) = showsUnaryWith sp "Pure" d a + go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa + +instance (Show1 f, Show a) => Show (Free f a) where + showsPrec = showsPrec1 + +instance Read1 f => Read1 (Free f) where + liftReadsPrec rp rl = go + where + go = readsData $ + readsUnaryWith rp "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free + +instance (Read1 f, Read a) => Read (Free f a) where + readsPrec = readsPrec1 + instance Functor f => Functor (Free f) where fmap f = go where go (Pure a) = Pure (f a) @@ -149,11 +182,14 @@ Free m >>- f = Free ((>>- f) <$> m) instance Functor f => Monad (Free f) where - return = Pure + return = pure {-# INLINE return #-} Pure a >>= f = f a Free m >>= f = Free ((>>= f) <$> m) +instance Functor f => MonadFix (Free f) where + mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" + -- | This violates the Alternative laws, handle with care. instance Alternative v => Alternative (Free v) where empty = Free empty @@ -162,7 +198,7 @@ {-# INLINE (<|>) #-} -- | This violates the MonadPlus laws, handle with care. -instance (Functor v, MonadPlus v) => MonadPlus (Free v) where +instance MonadPlus v => MonadPlus (Free v) where mzero = Free mzero {-# INLINE mzero #-} a `mplus` b = Free (return a `mplus` return b) @@ -179,6 +215,20 @@ go (Free fa) = foldMap go fa {-# INLINE foldMap #-} + foldr f = go where + go r free = + case free of + Pure a -> f a r + Free fa -> foldr (flip go) r fa + {-# INLINE foldr #-} + + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} + instance Foldable1 f => Foldable1 (Free f) where foldMap1 f = go where go (Pure a) = f a @@ -197,7 +247,22 @@ go (Free fa) = Free <$> traverse1 go fa {-# INLINE traverse1 #-} -instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where +instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where + imap f (Pure a) = Pure $ f [] a + imap f (Free s) = Free $ imap (\i -> imap (f . (:) i)) s + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where + ifoldMap f (Pure a) = f [] a + ifoldMap f (Free s) = ifoldMap (\i -> ifoldMap (f . (:) i)) s + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where + itraverse f (Pure a) = Pure <$> f [] a + itraverse f (Free s) = Free <$> itraverse (\i -> itraverse (f . (:) i)) s + {-# INLINE itraverse #-} + +instance MonadWriter e m => MonadWriter e (Free m) where tell = lift . tell {-# INLINE tell #-} listen = lift . listen . retract @@ -205,25 +270,25 @@ pass = lift . pass . retract {-# INLINE pass #-} -instance (Functor m, MonadReader e m) => MonadReader e (Free m) where +instance 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 +instance 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 +instance 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 +instance MonadCont m => MonadCont (Free m) where callCC f = lift (callCC (retract . f . liftM lift)) {-# INLINE callCC #-} @@ -247,16 +312,58 @@ iter _ (Pure a) = a iter phi (Free m) = phi (iter phi <$> m) --- | Like iter for monadic values. +-- | Like 'iter' for applicative values. +iterA :: (Applicative p, Functor f) => (f (p a) -> p a) -> Free f a -> p a +iterA _ (Pure x) = pure x +iterA phi (Free f) = phi (iterA phi <$> f) + +-- | Like 'iter' for monadic values. iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a iterM _ (Pure x) = return x -iterM phi (Free f) = phi $ fmap (iterM phi) f +iterM phi (Free f) = phi (iterM phi <$> f) --- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'FreeT' f@ to @'FreeT' g@. +-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'Free' f@ to @'Free' g@. hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b hoistFree _ (Pure a) = Pure a hoistFree f (Free as) = Free (hoistFree f <$> f as) +-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. +foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a +foldFree _ (Pure a) = return a +foldFree f (Free as) = f as >>= foldFree f + +-- | Convert a 'Free' monad from "Control.Monad.Free" to a 'FreeT.FreeT' monad +-- from "Control.Monad.Trans.Free". +toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a +toFreeT (Pure a) = FreeT.FreeT (return (FreeT.Pure a)) +toFreeT (Free f) = FreeT.FreeT (return (FreeT.Free (fmap toFreeT f))) + +-- | 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. +-- +-- Some examples (n ≥ 0): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a) +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, 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) @@ -273,60 +380,18 @@ {-# INLINE impure #-} {-# INLINE _Pure #-} --- | This is @Prism' (Free f a) (f (Free f a))@ in disguise +-- | This is @Prism (Free f a) (Free g a) (f (Free f a)) (g (Free g a))@ in disguise -- -- >>> preview _Free (review _Free (Just (Pure 3))) -- Just (Just (Pure 3)) -- -- >>> review _Free (Just (Pure 3)) -- Free (Just (Pure 3)) -_Free :: forall f m a p. (Choice p, Applicative m) - => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a)) +_Free :: forall f g m a p. (Choice p, Applicative m) + => p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a)) _Free = dimap unfree (either pure (fmap Free)) . right' where unfree (Free x) = Right x - unfree x = Left x + unfree (Pure x) = Left (Pure x) {-# INLINE unfree #-} {-# INLINE _Free #-} - - -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -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.Monad.Free.Free" -#else -freeTyCon = mkTyCon3 "free" "Control.Monad.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 - toConstr Pure{} = pureConstr - toConstr Free{} = freeConstr - gunfold k z c = case constrIndex c of - 1 -> k (z Pure) - 2 -> k (z Free) - _ -> error "gunfold" - dataTypeOf _ = freeDataType - dataCast1 f = gcast1 f - -pureConstr, freeConstr :: Constr -pureConstr = mkConstr freeDataType "Pure" [] Prefix -freeConstr = mkConstr freeDataType "Free" [] Prefix -{-# NOINLINE pureConstr #-} -{-# NOINLINE freeConstr #-} - -freeDataType :: DataType -freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr] -{-# NOINLINE freeDataType #-} - -#endif diff --git a/src/Control/Monad/Free/Ap.hs b/src/Control/Monad/Free/Ap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Free/Ap.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +-------------------------------------------------------------------------------- +-- | +-- \"Applicative Effects in Free Monads\" +-- +-- Often times, the '(\<*\>)' operator can be more efficient than 'ap'. +-- Conventional free monads don't provide any means of modeling this. +-- The free monad can be modified to make use of an underlying applicative. +-- But it does require some laws, or else the '(\<*\>)' = 'ap' law is broken. +-- When interpreting this free monad with 'foldFree', +-- the natural transformation must be an applicative homomorphism. +-- An applicative homomorphism @hm :: (Applicative f, Applicative g) => f x -> g x@ +-- will satisfy these laws. +-- +-- * @hm (pure a) = pure a@ +-- * @hm (f \<*\> a) = hm f \<*\> hm a@ +-- +-- This is based on the \"Applicative Effects in Free Monads\" series of articles by Will Fancher +-- +-- * +-- +-- * +-------------------------------------------------------------------------------- +module Control.Monad.Free.Ap + ( MonadFree(..) + , Free(..) + , retract + , liftF + , iter + , iterA + , iterM + , hoistFree + , foldFree + , toFreeT + , cutoff + , unfold + , unfoldM + , _Pure, _Free + ) where + +import Control.Applicative +import Control.Arrow ((>>>)) +import Control.Monad (liftM, MonadPlus(..), (>=>)) +import Control.Monad.Fix +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.Free.Ap as FreeT +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.Functor.Classes +import Data.Foldable +import Data.Profunctor +import Data.Traversable +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Data +import GHC.Generics +import Prelude hiding (foldr) + +-- $setup +-- >>> import Control.Applicative (Const (..)) +-- >>> import Data.Functor.Identity (Identity (..)) +-- >>> import Data.Monoid (First (..)) +-- >>> import Data.Tagged (Tagged (..)) +-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x)) +-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x)))) + +-- | A free monad given an applicative +data Free f a = Pure a | Free (f (Free f a)) + deriving (Generic, Generic1) + +deriving instance + ( Typeable f + , Data a, Data (f (Free f a)) + ) => Data (Free f a) + +instance Eq1 f => Eq1 (Free f) where + liftEq eq = go + where + go (Pure a) (Pure b) = eq a b + go (Free fa) (Free fb) = liftEq go fa fb + go _ _ = False + +instance (Eq1 f, Eq a) => Eq (Free f a) where + (==) = eq1 + +instance Ord1 f => Ord1 (Free f) where + liftCompare cmp = go + where + go (Pure a) (Pure b) = cmp a b + go (Pure _) (Free _) = LT + go (Free _) (Pure _) = GT + go (Free fa) (Free fb) = liftCompare go fa fb + +instance (Ord1 f, Ord a) => Ord (Free f a) where + compare = compare1 + +instance Show1 f => Show1 (Free f) where + liftShowsPrec sp sl = go + where + go d (Pure a) = showsUnaryWith sp "Pure" d a + go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa + +instance (Show1 f, Show a) => Show (Free f a) where + showsPrec = showsPrec1 + +instance Read1 f => Read1 (Free f) where + liftReadsPrec rp rl = go + where + go = readsData $ + readsUnaryWith rp "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free + +instance (Read1 f, Read a) => Read (Free f a) where + readsPrec = readsPrec1 + +instance Functor f => Functor (Free f) where + fmap f = go where + go (Pure a) = Pure (f a) + go (Free fa) = Free (go <$> fa) + {-# INLINE fmap #-} + +instance Apply f => Apply (Free f) where + Pure a <.> Pure b = Pure (a b) + Pure a <.> Free fb = Free $ fmap a <$> fb + Free fa <.> Pure b = Free $ fmap ($ b) <$> fa + Free fa <.> Free fb = Free $ fmap (<.>) fa <.> fb + +instance Applicative 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 <*> Pure b = Free $ fmap ($ b) <$> ma + Free ma <*> Free mb = Free $ fmap (<*>) ma <*> mb + +instance Apply f => Bind (Free f) where + Pure a >>- f = f a + Free m >>- f = Free ((>>- f) <$> m) + +instance Applicative f => Monad (Free f) where + return = pure + {-# INLINE return #-} + Pure a >>= f = f a + Free m >>= f = Free ((>>= f) <$> m) + +instance Applicative f => MonadFix (Free f) where + mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" + +-- | 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 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 = go where + go (Pure a) = f a + go (Free fa) = foldMap go fa + {-# INLINE foldMap #-} + + foldr f = go where + go r free = + case free of + Pure a -> f a r + Free fa -> foldr (flip go) r fa + {-# INLINE foldr #-} + + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} + +instance Foldable1 f => Foldable1 (Free f) where + 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 = 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 = go where + go (Pure a) = Pure <$> f a + go (Free fa) = Free <$> traverse1 go fa + {-# INLINE traverse1 #-} + +instance 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 MonadReader e m => MonadReader e (Free m) where + ask = lift ask + {-# INLINE ask #-} + local f = lift . local f . retract + {-# INLINE local #-} + +instance MonadState s m => MonadState s (Free m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + +instance 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 MonadCont m => MonadCont (Free m) where + callCC f = lift (callCC (retract . f . liftM lift)) + {-# INLINE callCC #-} + +instance Applicative 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 :: Monad f => Free f a -> f a +retract = foldFree id + +-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration. +iter :: Applicative f => (f a -> a) -> Free f a -> a +iter _ (Pure a) = a +iter phi (Free m) = phi (iter phi <$> m) + +-- | Like 'iter' for applicative values. +iterA :: (Applicative p, Applicative f) => (f (p a) -> p a) -> Free f a -> p a +iterA _ (Pure x) = pure x +iterA phi (Free f) = phi (iterA phi <$> f) + +-- | Like 'iter' for monadic values. +iterM :: (Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a +iterM _ (Pure x) = return x +iterM phi (Free f) = phi (iterM phi <$> f) + +-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'Free' f@ to @'Free' g@. +hoistFree :: (Applicative f, Applicative g) => (forall a. f a -> g a) -> Free f b -> Free g b +hoistFree f = foldFree (liftF . f) + +-- | Given an applicative homomorphism, you get a monad homomorphism. +foldFree :: (Applicative f, Monad m) => (forall x . f x -> m x) -> Free f a -> m a +foldFree _ (Pure a) = return a +foldFree f (Free as) = f as >>= foldFree f + +-- | Convert a 'Free' monad from "Control.Monad.Free.Ap" to a 'FreeT.FreeT' monad +-- from "Control.Monad.Trans.Free.Ap". +-- WARNING: This assumes that 'liftF' is an applicative homomorphism. +toFreeT :: (Applicative f, Monad m) => Free f a -> FreeT.FreeT f m a +toFreeT = foldFree liftF + +-- | 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. +-- +-- Some examples (n ≥ 0): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling 'retract . cutoff n' is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Applicative f) => Integer -> Free f a -> Free f (Maybe a) +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 :: Applicative 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 :: (Applicative f, Traversable f, 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) +-- Just 3 +-- +-- >>> review _Pure 3 :: Free Maybe Int +-- Pure 3 +_Pure :: forall f m a p. (Choice p, Applicative m) + => p a (m a) -> p (Free f a) (m (Free f a)) +_Pure = dimap impure (either pure (fmap Pure)) . right' + where + impure (Pure x) = Right x + impure x = Left x + {-# INLINE impure #-} +{-# INLINE _Pure #-} + +-- | This is @Prism' (Free f a) (f (Free f a))@ in disguise +-- +-- >>> preview _Free (review _Free (Just (Pure 3))) +-- Just (Just (Pure 3)) +-- +-- >>> review _Free (Just (Pure 3)) +-- Free (Just (Pure 3)) +_Free :: forall f m a p. (Choice p, Applicative m) + => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a)) +_Free = dimap unfree (either pure (fmap Free)) . right' + where + unfree (Free x) = Right x + unfree x = Left x + {-# INLINE unfree #-} +{-# INLINE _Free #-} diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free.Church --- Copyright : (C) 2011-2012 Edward Kmett +-- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -14,41 +17,83 @@ -- -- \"Free Monads for Less\" -- --- This is based on the \"Free Monads for Less\" series of articles: +-- The most straightforward way of implementing free monads is as a recursive +-- datatype that allows for arbitrarily deep nesting of the base functor. This is +-- akin to a tree, with the leaves containing the values, and the nodes being a +-- level of 'Functor' over subtrees. -- --- --- +-- For each time that the `fmap` or `>>=` operations is used, the old tree is +-- traversed up to the leaves, a new set of nodes is allocated, and +-- the old ones are garbage collected. Even if the Haskell runtime +-- optimizes some of the overhead through laziness and generational garbage +-- collection, the asymptotic runtime is still quadratic. +-- +-- On the other hand, if the Church encoding is used, the tree only needs to be +-- constructed once, because: +-- +-- * All uses of `fmap` are collapsed into a single one, so that the values on the +-- _leaves_ are transformed in one pass. +-- +-- prop> fmap f . fmap g == fmap (f . g) +-- +-- * All uses of `>>=` are right associated, so that every new subtree created +-- is final. +-- +-- prop> (m >>= f) >>= g == m >>= (\x -> f x >>= g) +-- +-- Asymptotically, the Church encoding supports the monadic operations more +-- efficiently than the naïve 'Free'. +-- +-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: +-- +-- * +-- +-- * ---------------------------------------------------------------------------- module Control.Monad.Free.Church ( F(..) , improve , fromF + , iter , iterM , toF , retract + , hoistF + , foldF , MonadFree(..) , liftF + , cutoff ) where import Control.Applicative import Control.Monad as Monad -import Control.Monad.Free hiding (retract, iterM) +import Control.Monad.Fix +import Control.Monad.Free hiding (retract, iter, iterM, cutoff) import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Cont.Class import Control.Monad.Trans.Class import Control.Monad.State.Class +import Data.Foldable +import Data.Traversable import Data.Functor.Bind +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Prelude hiding (foldr) -- | The Church-encoded free monad for a functor @f@. -- -- It is /asymptotically/ more efficient to use ('>>=') for 'F' than it is to ('>>=') with 'Free'. -- --- +-- newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } +-- | Tear down a 'Free' 'Monad' using iteration. +iter :: (f a -> a) -> F f a -> a +iter phi xs = runF xs id phi + -- | Like iter for monadic values. -iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> F f a -> m a +iterM :: Monad m => (f (m a) -> m a) -> F f a -> m a iterM phi xs = runF xs return phi instance Functor (F f) where @@ -59,8 +104,9 @@ instance Applicative (F f) where pure a = F (\kp _ -> kp a) - F f <*> F g = F (\kp kf -> f (\a -> g (\b -> kp (a b)) kf) kf) + F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf) +-- | This violates the Alternative laws, handle with care. instance Alternative f => Alternative (F f) where empty = F (\_ kf -> kf empty) F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf))) @@ -69,9 +115,35 @@ (>>-) = (>>=) instance Monad (F f) where - return a = F (\kp _ -> kp a) + return = pure F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) +instance MonadFix (F f) where + mfix f = a where + a = f (impure a) + impure (F x) = x id (error "MonadFix (F f): wrap") + +instance Foldable f => Foldable (F f) where + foldMap f xs = runF xs f fold + {-# INLINE foldMap #-} + + foldr f r xs = runF xs f (foldr (.) id) r + {-# INLINE foldr #-} + + foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z + {-# INLINE foldl' #-} + +instance Traversable f => Traversable (F f) where + traverse f m = runF m (fmap return . f) (fmap wrap . sequenceA) + {-# INLINE traverse #-} + +instance Foldable1 f => Foldable1 (F f) where + foldMap1 f m = runF m f fold1 + +instance Traversable1 f => Traversable1 (F f) where + traverse1 f m = runF m (fmap return . f) (fmap wrap . sequence1) + +-- | This violates the MonadPlus laws, handle with care. instance MonadPlus f => MonadPlus (F f) where mzero = F (\_ kf -> kf mzero) F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf))) @@ -109,6 +181,14 @@ retract (F m) = m return Monad.join {-# INLINE retract #-} +-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @F f@ to @F g@. +hoistF :: (forall x. f x -> g x) -> F f a -> F g a +hoistF t (F m) = F (\p f -> m p (f . t)) + +-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. +foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a +foldF f (F m) = m return (Monad.join . f) + -- | Convert to another free monad representation. fromF :: MonadFree f m => F f a -> m a fromF (F m) = m return wrap @@ -124,12 +204,46 @@ -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: -- --- --- +-- * -- --- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: +-- * -- --- +-- and by Janis Voightländer. improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = fromF m {-# INLINE improve #-} + + +-- | 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. +-- +-- Some examples (@n ≥ 0@): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +{-# INLINE cutoff #-} +cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a) +cutoff n m + | n <= 0 = return Nothing + | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m + | otherwise = cutoffI n m + +{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-} +{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-} +cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a) +cutoffI n m = F m' where + m' kp kf = runF m kpn kfn n where + kpn a i + | i <= 0 = kp Nothing + | otherwise = kp (Just a) + kfn fr i + | i <= 0 = kp Nothing + | otherwise = let + i' = i - 1 + in i' `seq` kf (fmap ($ i') fr) diff --git a/src/Control/Monad/Free/Class.hs b/src/Control/Monad/Free/Class.hs --- a/src/Control/Monad/Free/Class.hs +++ b/src/Control/Monad/Free/Class.hs @@ -1,11 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if !(MIN_VERSION_transformers(0,6,0)) +{-# OPTIONS_GHC -Wno-deprecations #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free.Class --- Copyright : (C) 2008-2011 Edward Kmett +-- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -17,9 +26,11 @@ module Control.Monad.Free.Class ( MonadFree(..) , liftF + , wrapT ) where -import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.State.Lazy as Lazy @@ -29,15 +40,18 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe -import Control.Monad.Trans.List -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.Trans.Identity -import Data.Monoid +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + -- | -- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'): -- --- @m '>>=' f = 'Control.Monad.join' . 'fmap' f m@ +-- @m '>>=' f = 'Control.Monad.join' ('fmap' f m)@ -- -- A free 'Monad' is one that does no work during the normalization step beyond simply grafting the two monadic values together. -- @@ -72,15 +86,23 @@ -- Or we could choose to program with @'Control.Monad.Free.Free' Pair@ instead of 'Tree' -- and thereby avoid having to define our own 'Monad' instance. -- --- Moreover, the @kan-extensions@ package provides 'MonadFree' instances that can --- improve the /asymptotic/ complexity of code that constructors free monads by --- effectively reassociating the use of ('>>='). +-- Moreover, "Control.Monad.Free.Church" provides a 'MonadFree' +-- instance that can improve the /asymptotic/ complexity of code that +-- constructs free monads by effectively reassociating the use of +-- ('>>='). You may also want to take a look at the @kan-extensions@ +-- package (). -- -- See 'Control.Monad.Free.Free' for a more formal definition of the free 'Monad' -- for a 'Functor'. class Monad m => MonadFree f m | m -> f where -- | Add a layer. + -- + -- @ + -- wrap (fmap f x) ≡ wrap (fmap return x) >>= f + -- @ wrap :: f (m a) -> m a + default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a + wrap = join . lift . wrap . fmap return instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm @@ -112,12 +134,27 @@ instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where wrap = IdentityT . wrap . fmap runIdentityT -instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where - wrap = ListT . wrap . fmap runListT +instance (Functor f, MonadFree f m) => MonadFree f (ExceptT e m) where + wrap = ExceptT . wrap . fmap runExceptT +-- instance (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where +-- wrap = EitherT . wrap . fmap runEitherT + +#if !(MIN_VERSION_transformers(0,6,0)) instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where wrap = ErrorT . wrap . fmap runErrorT +instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where + wrap = ListT . wrap . fmap runListT +#endif + -- | A version of lift that can be used with just a Functor for f. liftF :: (Functor f, MonadFree f m) => f a -> m a liftF = wrap . fmap return + +-- | A version of wrap for monad transformers over a free monad. +-- +-- /Note:/ that this is the default implementation for 'wrap' for +-- @MonadFree f (t m)@. +wrapT :: (Functor f, MonadFree f m, MonadTrans t, Monad (t m)) => f (t m a) -> t m a +wrapT = join . lift . liftF diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Free/TH.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE CPP #-} +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.TH +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Automatic generation of free monadic actions. +-- +---------------------------------------------------------------------------- +module Control.Monad.Free.TH + ( + -- * Free monadic actions + makeFree, + makeFree_, + makeFreeCon, + makeFreeCon_, + + -- * Documentation + -- $doc + + -- * Examples + -- $examples + ) where + +import Control.Arrow +import Control.Monad +import Data.Char (toLower) +import Data.List ((\\), nub) +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Ppr (pprint) +import Language.Haskell.TH.Syntax + +data Arg + = Captured Type Exp + | Param Type + deriving (Show) + +params :: [Arg] -> [Type] +params [] = [] +params (Param t : xs) = t : params xs +params (_ : xs) = params xs + +captured :: [Arg] -> [(Type, Exp)] +captured [] = [] +captured (Captured t e : xs) = (t, e) : captured xs +captured (_ : xs) = captured xs + +zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp] +zipExprs (p:ps) cs (Param _ : as) = p : zipExprs ps cs as +zipExprs ps (c:cs) (Captured _ _ : as) = c : zipExprs ps cs as +zipExprs _ _ _ = [] + +findTypeOrFail :: String -> Q Name +findTypeOrFail s = lookupTypeName s >>= maybe (fail $ s ++ " is not in scope") return + +findValueOrFail :: String -> Q Name +findValueOrFail s = lookupValueName s >>= maybe (fail $ s ++ "is not in scope") return + +-- | Pick a name for an operation. +-- For normal constructors it lowers first letter. +-- For infix ones it omits the first @:@. +mkOpName :: String -> Q String +mkOpName (':':name) = return name +mkOpName ( c :name) = return $ toLower c : name +mkOpName _ = fail "impossible happened: empty (null) constructor name" + +-- | Check if parameter is used in type. +usesTV :: Name -> Type -> Bool +usesTV n (VarT name) = n == name +usesTV n (AppT t1 t2) = any (usesTV n) [t1, t2] +usesTV n (SigT t _ ) = usesTV n t +usesTV n (ForallT bs _ t) = usesTV n t && n `notElem` map tvName bs +usesTV _ _ = False + +-- | Analyze constructor argument. +mkArg :: Type -> Type -> Q Arg +mkArg (VarT n) t + | usesTV n t = + case t of + -- if parameter is used as is, the return type should be () + -- as well as the corresponding expression + VarT _ -> return $ Captured (TupleT 0) (TupE []) + -- if argument is of type (a1 -> ... -> aN -> param) then the + -- return type is N-tuple (a1, ..., aN) and the corresponding + -- expression is an N-tuple secion (,...,). + AppT (AppT ArrowT _) _ -> do + (ts, name) <- arrowsToTuple t + when (any (usesTV n) ts) $ fail $ unlines + [ "type variable " ++ pprint n ++ " is forbidden" + , "in a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")" + , "in a constructor's argument type: " ++ pprint t ] + when (name /= n) $ fail $ unlines + [ "expected final return type `" ++ pprint n ++ "'" + , "but got `" ++ pprint name ++ "'" + , "in a constructor's argument type: `" ++ pprint t ++ "'" ] + let tup = nonUnaryTupleT ts + xs <- mapM (const $ newName "x") ts + return $ Captured tup (LamE (map VarP xs) (nonUnaryTupE $ map VarE xs)) + _ -> fail $ unlines + [ "expected a type variable `" ++ pprint n ++ "'" + , "or a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")" + , "but got `" ++ pprint t ++ "'" + , "in a constructor's argument" ] + | otherwise = return $ Param t + where + arrowsToTuple (AppT (AppT ArrowT t1) t2) = do + (ts, name) <- arrowsToTuple t2 + return (t1:ts, name) + arrowsToTuple (VarT name) = return ([], name) + arrowsToTuple rt = fail $ unlines + [ "expected final return type `" ++ pprint n ++ "'" + , "but got `" ++ pprint rt ++ "'" + , "in a constructor's argument type: `" ++ pprint t ++ "'" ] + + nonUnaryTupleT :: [Type] -> Type + nonUnaryTupleT [t'] = t' + nonUnaryTupleT ts = foldl AppT (TupleT $ length ts) ts + + nonUnaryTupE :: [Exp] -> Exp + nonUnaryTupE [e] = e + nonUnaryTupE es = TupE $ +#if MIN_VERSION_template_haskell(2,16,0) + map Just +#endif + es + +mkArg n _ = fail $ unlines + [ "expected a type variable" + , "but got `" ++ pprint n ++ "'" + , "as the last parameter of the type constructor" ] + +-- | Apply transformation to the return value independently of how many +-- parameters does @e@ have. +-- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to +-- @\x y z -> Just (x + y * z)@ +mapRet :: (Exp -> Exp) -> Exp -> Exp +mapRet f (LamE ps e) = LamE ps $ mapRet f e +mapRet f e = f e + +-- | Unification of two types. +-- @next@ with @a -> next@ gives @Maybe a@ return type +-- @a -> next@ with @b -> next@ gives @Either a b@ return type +unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp]) +unifyT (TupleT 0, _) (TupleT 0, _) = fail "can't accept 2 mere parameters" +unifyT (TupleT 0, _) (t, e) = do + maybe' <- ConT <$> findTypeOrFail "Maybe" + nothing' <- ConE <$> findValueOrFail "Nothing" + just' <- ConE <$> findValueOrFail "Just" + return (AppT maybe' t, [nothing', mapRet (AppE just') e]) +unifyT x y@(TupleT 0, _) = second reverse <$> unifyT y x +unifyT (t1, e1) (t2, e2) = do + either' <- ConT <$> findTypeOrFail "Either" + left' <- ConE <$> findValueOrFail "Left" + right' <- ConE <$> findValueOrFail "Right" + return (AppT (AppT either' t1) t2, [mapRet (AppE left') e1, mapRet (AppE right') e2]) + +-- | Unifying a list of types (possibly refining expressions). +-- Name is used when the return type is supposed to be arbitrary. +unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp]) +unifyCaptured a [] = return (VarT a, []) +unifyCaptured _ [(t, e)] = return (t, [e]) +unifyCaptured _ [x, y] = unifyT x y +unifyCaptured _ xs = fail $ unlines + [ "can't unify more than 2 return types" + , "that use type parameter" + , "when unifying return types: " + , unlines (map (pprint . fst) xs) ] + +extractVars :: Type -> [Name] +extractVars (ForallT bs _ t) = extractVars t \\ map tvName bs +extractVars (VarT n) = [n] +extractVars (AppT x y) = extractVars x ++ extractVars y +extractVars (SigT x k) = extractVars x ++ extractVars k +extractVars (InfixT x _ y) = extractVars x ++ extractVars y +extractVars (UInfixT x _ y) = extractVars x ++ extractVars y +extractVars (ParensT x) = extractVars x +extractVars _ = [] + +liftCon' :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec] +liftCon' typeSig tvbs cx f n ns cn ts = do + -- prepare some names + opName <- mkName <$> mkOpName (nameBase cn) + m <- newName "m" + a <- newName "a" + monadFree <- findTypeOrFail "MonadFree" + liftF <- findValueOrFail "liftF" + -- look at the constructor parameters + args <- mapM (mkArg n) ts + let ps = params args -- these are not using type parameter + cs = captured args -- these capture it somehow + -- based on cs we get return type and refined expressions + -- (e.g. with Nothing/Just or Left/Right tags) + (retType, es) <- unifyCaptured a cs + -- operation type is (a1 -> a2 -> ... -> aN -> m r) + let opType = foldr (AppT . AppT ArrowT) (AppT (VarT m) retType) ps + -- picking names for the implementation + xs <- mapM (const $ newName "p") ps + let pat = map VarP xs -- this is LHS + exprs = zipExprs (map VarE xs) es args -- this is what ctor would be applied to + fval = foldl AppE (ConE cn) exprs -- this is RHS without liftF + ns' = nub (concatMap extractVars ns) + q = filter nonNext tvbs ++ map plainTVSpecified (qa ++ m : ns') + qa = case retType of VarT b | a == b -> [a]; _ -> [] + f' = foldl AppT f ns + return $ concat + [ if typeSig + then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ] + else [] + , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ] + where + nonNext tv = VarT (tvName tv) /= n + +-- | Provide free monadic actions for a single value constructor. +liftCon :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec] +liftCon typeSig ts cx f n ns onlyCons con + | not (any (`melem` onlyCons) (constructorNames con)) = return [] + | otherwise = case con of + NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields + RecC cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields + InfixC (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2] + ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns onlyCons con' + GadtC cNames fields resType -> do + decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> + liftGadtC cName fields resType typeSig ts cx f + return (concat decs) + RecGadtC cNames fields resType -> do + let fields' = map (\(_, x, y) -> (x, y)) fields + decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> + liftGadtC cName fields' resType typeSig ts cx f + return (concat decs) + +splitAppT :: Type -> (Type, [Type]) +splitAppT ty = go ty ty [] + where + go :: Type -> Type -> [Type] -> (Type, [Type]) + go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) + go origTy (SigT ty' _) args = go origTy ty' args + go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args + go origTy (ParensT ty') args = go origTy ty' args + go origTy _ args = (origTy, args) + +liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Q [Dec] +liftGadtC cName fields resType typeSig ts cx f = + liftCon typeSig ts cx f nextTy (init tys) Nothing (NormalC cName fields) + where + (_f, tys) = splitAppT resType + nextTy = last tys + +melem :: Eq a => a -> Maybe [a] -> Bool +melem _ Nothing = True +melem x (Just xs) = x `elem` xs + +-- | Get construstor name(s). +constructorNames :: Con -> [Name] +constructorNames (NormalC name _) = [name] +constructorNames (RecC name _) = [name] +constructorNames (InfixC _ name _) = [name] +constructorNames (ForallC _ _ c) = constructorNames c +constructorNames (GadtC names _ _) = names +constructorNames (RecGadtC names _ _) = names + +-- | Provide free monadic actions for a type declaration. +liftDec :: Bool -- ^ Include type signature? + -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. + -> Dec -- ^ Data type declaration. + -> Q [Dec] +liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _) + | null tyVarBndrs = fail $ "Type constructor " ++ pprint tyName ++ " needs at least one type parameter" + | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTy (init tys) onlyCons) cons + where + tys = map (VarT . tvName) tyVarBndrs + nextTy = last tys + con = ConT tyName +liftDec _ _ dec = fail $ unlines + [ "failed to derive makeFree operations:" + , "expected a data type constructor" + , "but got " ++ pprint dec ] + +-- | Generate monadic actions for a data type. +genFree :: Bool -- ^ Include type signature? + -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. + -> Name -- ^ Type name. + -> Q [Dec] -- ^ Generated declarations. +genFree typeSig cnames tyCon = do + info <- reify tyCon + case info of + TyConI dec -> liftDec typeSig cnames dec + _ -> fail "makeFree expects a type constructor" + +-- | Generate monadic action for a single constructor of a data type. +genFreeCon :: Bool -- ^ Include type signature? + -> Name -- ^ Constructor name. + -> Q [Dec] -- ^ Generated declarations. +genFreeCon typeSig cname = do + info <- reify cname + case info of + DataConI _ _ tname -> genFree typeSig (Just [cname]) tname + _ -> fail $ unlines + [ "expected a data constructor" + , "but got " ++ pprint info ] + +-- | @$('makeFree' ''T)@ provides free monadic actions for the +-- constructors of the given data type @T@. +makeFree :: Name -> Q [Dec] +makeFree = genFree True Nothing + +-- | Like 'makeFree', but does not provide type signatures. +-- This can be used to attach Haddock comments to individual arguments +-- for each generated function. +-- +-- @ +-- data LangF x = Output String x +-- +-- makeFree_ 'LangF +-- +-- -- | Output a string. +-- output :: MonadFree LangF m => +-- String -- ^ String to output. +-- -> m () -- ^ No result. +-- @ +-- +-- 'makeFree_' must be called *before* the explicit type signatures. +makeFree_ :: Name -> Q [Dec] +makeFree_ = genFree False Nothing + +-- | @$('makeFreeCon' 'Con)@ provides free monadic action for a data +-- constructor @Con@. Note that you can attach Haddock comment to the +-- generated function by placing it before the top-level invocation of +-- 'makeFreeCon': +-- +-- @ +-- -- | Output a string. +-- makeFreeCon 'Output +-- @ +makeFreeCon :: Name -> Q [Dec] +makeFreeCon = genFreeCon True + +-- | Like 'makeFreeCon', but does not provide a type signature. +-- This can be used to attach Haddock comments to individual arguments. +-- +-- @ +-- data LangF x = Output String x +-- +-- makeFreeCon_ 'Output +-- +-- -- | Output a string. +-- output :: MonadFree LangF m => +-- String -- ^ String to output. +-- -> m () -- ^ No result. +-- @ +-- +-- 'makeFreeCon_' must be called *before* the explicit type signature. +makeFreeCon_ :: Name -> Q [Dec] +makeFreeCon_ = genFreeCon False + +{- $doc + To generate free monadic actions from a @Type@, it must be a @data@ + declaration (maybe GADT) with at least one free variable. For each constructor of the type, a + new function will be declared. + + Consider the following generalized definitions: + + > data Type a1 a2 … aN param = … + > | FooBar t1 t2 t3 … tJ + > | (:+) t1 t2 t3 … tJ + > | t1 :* t2 + > | t1 `Bar` t2 + > | Baz { x :: t1, y :: t2, …, z :: tJ } + > | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ + > | … + + where each of the constructor arguments @t1, …, tJ@ is either: + + 1. A type, perhaps depending on some of the @a1, …, aN@. + + 2. A type dependent on @param@, of the form @s1 -> … -> sM -> param@, M ≥ 0. + At most 2 of the @t1, …, tJ@ may be of this form. And, out of these two, + at most 1 of them may have @M == 0@; that is, be of the form @param@. + + For each constructor, a function will be generated. First, the name + of the function is derived from the name of the constructor: + + * For prefix constructors, the name of the constructor with the first + letter in lowercase (e.g. @FooBar@ turns into @fooBar@). + + * For infix constructors, the name of the constructor with the first + character (a colon @:@), removed (e.g. @:+@ turns into @+@). + + Then, the type of the function is derived from the arguments to the constructor: + + > … + > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > (+) :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > bar :: (MonadFree Type m) => t1 -> … -> tK' -> m ret + > baz :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > qux :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret + > … + + The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the + @a1, …, aN@. + + The type @ret@ depends on those constructor arguments that reference the + @param@ type variable: + + 1. If no arguments to the constructor depend on @param@, @ret ≡ a@, where + @a@ is a fresh type variable. + + 2. If only one argument in the constructor depends on @param@, then + @ret ≡ (s1, …, sM)@. In particular, if @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@. + + 3. If two arguments depend on @param@, (e.g. @u1 -> … -> uL -> param@ and + @v1 -> … -> vM -> param@, then @ret ≡ Either (u1, …, uL) (v1, …, vM)@. + + Note that @Either a ()@ and @Either () a@ are both isomorphic to @Maybe a@. + Because of this, when @L == 0@ or @M == 0@ in case 3., the type of + @ret@ is simplified: + + * @ret ≡ Either (u1, …, uL) ()@ is rewritten to @ret ≡ Maybe (u1, …, uL)@. + + * @ret ≡ Either () (v1, …, vM)@ is rewritten to @ret ≡ Maybe (v1, …, vM)@. + +-} + +{- $examples + + (regular data type declaration) + + (GADT declaration) + +-} diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif +{-# LANGUAGE Safe #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Free --- Copyright : (C) 2008-2012 Edward Kmett +-- Copyright : (C) 2008-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -21,86 +22,186 @@ -- ---------------------------------------------------------------------------- module Control.Monad.Trans.Free - ( FreeF(..) + ( + -- * The base functor + FreeF(..) + -- * The free monad transformer , FreeT(..) - , MonadFree(..) + -- * The free monad + , Free, free, runFree + -- * Operations , liftF , iterT + , iterTM , hoistFreeT + , foldFreeT , transFreeT + , joinFreeT + , cutoff + , partialIterT + , intersperseT + , intercalateT + , retractT + -- * Operations of free monad + , retract + , iter + , iterM + -- * Free Monads With Class + , MonadFree(..) ) where import Control.Applicative -import Control.Monad (liftM, MonadPlus(..), ap) +import Control.Monad (liftM, MonadPlus(..), ap, join) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class import Control.Monad.Free.Class +import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class -import Data.Monoid -import Data.Foldable +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 hiding (join) +import Data.Functor.Classes +import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable -#ifdef GHC_TYPEABLE import Data.Data -#endif +import GHC.Generics -- | The base functor for a free monad. data FreeF f a b = Pure a | Free (f b) - deriving (Eq,Ord,Show,Read -#if __GLASGOW_HASKELL__ >= 707 - ,Typeable -#endif - ) + deriving (Eq,Ord,Show,Read,Generic,Generic1,Data) +instance Show1 f => Show2 (FreeF f) where + liftShowsPrec2 spa _sla _spb _slb d (Pure a) = + showsUnaryWith spa "Pure" d a + liftShowsPrec2 _spa _sla spb slb d (Free as) = + showsUnaryWith (liftShowsPrec spb slb) "Free" d as + +instance (Show1 f, Show a) => Show1 (FreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (FreeF f) where + liftReadsPrec2 rpa _rla rpb rlb = readsData $ + readsUnaryWith rpa "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free + +instance (Read1 f, Read a) => Read1 (FreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (FreeF f) where + liftEq2 eq _ (Pure a) (Pure b) = eq a b + liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs + liftEq2 _ _ _ _ = False + +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (FreeF f) where + liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b + liftCompare2 _ _ (Pure _) (Free _) = LT + liftCompare2 _ _ (Free _) (Pure _) = GT + liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb + +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + liftCompare = liftCompare2 compare + instance Functor f => Functor (FreeF f a) where fmap _ (Pure a) = Pure a fmap f (Free as) = Free (fmap f as) + {-# INLINE fmap #-} instance Foldable f => Foldable (FreeF f a) where foldMap f (Free as) = foldMap f as foldMap _ _ = mempty + {-# INLINE foldMap #-} instance Traversable f => Traversable (FreeF f a) where traverse _ (Pure a) = pure (Pure a) traverse f (Free as) = Free <$> traverse f as + {-# INLINE traverse #-} instance Functor f => Bifunctor (FreeF f) where bimap f _ (Pure a) = Pure (f a) bimap _ g (Free as) = Free (fmap g as) + {-# INLINE bimap #-} instance Foldable f => Bifoldable (FreeF f) where bifoldMap f _ (Pure a) = f a bifoldMap _ g (Free as) = foldMap g as + {-# INLINE bifoldMap #-} instance Traversable f => Bitraversable (FreeF f) where bitraverse f _ (Pure a) = Pure <$> f a bitraverse _ g (Free as) = Free <$> traverse g as + {-# INLINE bitraverse #-} transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b transFreeF _ (Pure a) = Pure a transFreeF t (Free as) = Free (t as) {-# INLINE transFreeF #-} --- | The \"free monad transformer\" for a functor @f@. +-- | The \"free monad transformer\" for a functor @f@ newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) } -instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a) where - FreeT m == FreeT n = m == n +-- | The \"free monad\" for a functor @f@. +type Free f = FreeT f Identity -instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a) where - compare (FreeT m) (FreeT n) = compare m n +-- | Evaluates the first layer out of a free monad value. +runFree :: Free f a -> FreeF f a (Free f a) +runFree = runIdentity . runFreeT +{-# INLINE runFree #-} -instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where - showsPrec d (FreeT m) = showParen (d > 10) $ - showString "FreeT " . showsPrec 11 m +-- | Pushes a layer into a free monad value. +free :: FreeF f a (Free f a) -> Free f a +free = FreeT . Identity +{-# INLINE free #-} -instance Read (m (FreeF f a (FreeT f m a))) => Read (FreeT f m a) where - readsPrec d = readParen (d > 10) $ \r -> - [ (FreeT m,t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec 11 s] +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where + (==) = eq1 -instance (Functor f, Monad m) => Functor (FreeT f m) where - fmap f (FreeT m) = FreeT (liftM f' m) where +instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where + liftEq eq = go + where + go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where + compare = compare1 + +instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where + liftCompare cmp = go + where + go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 f, Show1 m) => Show1 (FreeT f m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (FreeT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "FreeT" d x + +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where + showsPrec = showsPrec1 + +instance (Read1 f, Read1 m) => Read1 (FreeT f m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "FreeT" FreeT + +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where + readsPrec = readsPrec1 + +instance (Functor f, Functor m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (fmap f' m) where f' (Pure a) = Pure (f a) f' (Free as) = Free (fmap (fmap f) as) @@ -110,14 +211,27 @@ (<*>) = ap {-# INLINE (<*>) #-} +instance (Functor f, Monad m) => Apply (FreeT f m) where + (<.>) = (<*>) + +instance (Functor f, Monad m) => Bind (FreeT f m) where + (>>-) = (>>=) + instance (Functor f, Monad m) => Monad (FreeT f m) where - return a = FreeT (return (Pure a)) + return = pure {-# INLINE return #-} FreeT m >>= f = FreeT $ m >>= \v -> case v of Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>= f) w)) -instance MonadTrans (FreeT f) where +#if !MIN_VERSION_base(4,13,0) + fail e = FreeT (fail e) +#endif + +instance (Functor f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where + fail e = FreeT (Fail.fail e) + +instance Functor f => MonadTrans (FreeT f) where lift = FreeT . liftM Pure {-# INLINE lift #-} @@ -125,6 +239,48 @@ liftIO = lift . liftIO {-# INLINE liftIO #-} +instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where + liftBase = lift . liftBase + {-# INLINE liftBase #-} + +instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Functor f, MonadWriter w m) => MonadWriter w (FreeT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Pure x, w) = Pure (x, w) + concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y + pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) + g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f) + +instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where + callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) + instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where empty = FreeT mzero FreeT ma <|> FreeT mb = FreeT (mplus ma mb) @@ -140,6 +296,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 @@ -148,6 +313,14 @@ Pure x -> return x Free y -> f y +-- | 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) -> FreeT f m a -> t m a +iterTM f (FreeT m) = do + val <- lift m + case fmap (iterTM f) val of + Pure x -> return x + Free y -> f y + instance (Foldable m, Foldable f) => Foldable (FreeT f m) where foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m @@ -156,78 +329,121 @@ -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ -- --- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ -hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b -hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT +-- @'hoistFreeT' :: ('Functor' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ +hoistFreeT :: (Functor m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b +hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT --- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g n@ +-- | The very definition of a free monad transformer is that given a natural +-- transformation you get a monad transformer homomorphism. +foldFreeT :: (MonadTrans t, Monad (t m), Monad m) + => (forall n x. Monad n => f x -> t n x) -> FreeT f m a -> t m a +foldFreeT f (FreeT m) = lift m >>= foldFreeF + where + foldFreeF (Pure a) = return a + foldFreeF (Free as) = f as >>= foldFreeT f + +-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ 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 -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -instance Typeable1 f => Typeable2 (FreeF f) where - typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where - f :: FreeF f a b -> f a - f = undefined +-- | 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 -instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where - typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where - f :: FreeT f w a -> f a - f = undefined - w :: FreeT f w a -> w a - w = undefined +-- | +-- 'retract' is the left inverse of 'liftF' +-- +-- @ +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => Free f a -> f a +retract m = + case runIdentity (runFreeT m) of + Pure a -> return a + Free as -> as >>= retract -freeFTyCon, freeTTyCon :: TyCon -#if __GLASGOW_HASKELL__ < 704 -freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT" -freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF" -#else -freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT" -freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF" -#endif -{-# NOINLINE freeTTyCon #-} -{-# NOINLINE freeFTyCon #-} +-- | Tear down a 'Free' 'Monad' using iteration. +iter :: Functor f => (f a -> a) -> Free f a -> a +iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) -instance - ( Typeable1 f, Typeable a, Typeable b - , Data a, Data (f b), Data b - ) => Data (FreeF f a b) where - gfoldl f z (Pure a) = z Pure `f` a - gfoldl f z (Free as) = z Free `f` as - toConstr Pure{} = pureConstr - toConstr Free{} = freeConstr - gunfold k z c = case constrIndex c of - 1 -> k (z Pure) - 2 -> k (z Free) - _ -> error "gunfold" - dataTypeOf _ = freeFDataType - dataCast1 f = gcast1 f +-- | Like 'iter' for monadic values. +iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a +iterM phi = iterT phi . hoistFreeT (return . runIdentity) -instance - ( Typeable1 f, Typeable1 w, Typeable a - , Data (w (FreeF f a (FreeT f w a))) - , Data a - ) => Data (FreeT f w a) where - gfoldl f z (FreeT w) = z FreeT `f` w - toConstr _ = freeTConstr - gunfold k z c = case constrIndex c of - 1 -> k (z FreeT) - _ -> error "gunfold" - dataTypeOf _ = freeTDataType - dataCast1 f = gcast1 f +-- | 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. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'cutoff' 0 _ ≡ 'return' 'Nothing' +-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' +-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' +-- 'cutoff' (n+1) '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('cutoff' n) +-- @ +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a) +cutoff n _ | n <= 0 = return Nothing +cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m -pureConstr, freeConstr, freeTConstr :: Constr -pureConstr = mkConstr freeFDataType "Pure" [] Prefix -freeConstr = mkConstr freeFDataType "Free" [] Prefix -freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix -{-# NOINLINE pureConstr #-} -{-# NOINLINE freeConstr #-} -{-# NOINLINE freeTConstr #-} +-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@. +-- This is sort of the opposite for @'cutoff'@. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'partialIterT' 0 _ m ≡ m +-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return' +-- 'partialIterT' (n+1) phi '.' 'lift' ≡ 'lift' +-- 'partialIterT' (n+1) phi '.' 'wrap' ≡ 'join' . 'lift' . phi +-- @ +partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b +partialIterT n phi m + | n <= 0 = m + | otherwise = FreeT $ do + val <- runFreeT m + case val of + Pure a -> return (Pure a) + Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi -freeFDataType, freeTDataType :: DataType -freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr] -freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr] -{-# NOINLINE freeFDataType #-} -{-# NOINLINE freeTDataType #-} -#endif +-- | @intersperseT f m@ inserts a layer @f@ between every two layers in +-- @m@. +-- +-- @ +-- 'intersperseT' f '.' 'return' ≡ 'return' +-- 'intersperseT' f '.' 'lift' ≡ 'lift' +-- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap')) +-- @ +intersperseT :: (Monad m, Functor f) => f a -> FreeT f m b -> FreeT f m b +intersperseT f (FreeT m) = FreeT $ do + val <- m + case val of + Pure x -> return $ Pure x + Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y +-- | Tear down a free monad transformer using Monad instance for @t m@. +retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a +retractT (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= retractT + +-- | @intercalateT f m@ inserts a layer @f@ between every two layers in +-- @m@ and then retracts the result. +-- +-- @ +-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f +-- @ +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) diff --git a/src/Control/Monad/Trans/Free/Ap.hs b/src/Control/Monad/Trans/Free/Ap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Free/Ap.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- +-- | +-- Given an applicative, the free monad transformer. +-------------------------------------------------------------------------------- + +module Control.Monad.Trans.Free.Ap + ( + -- * The base functor + FreeF(..) + -- * The free monad transformer + , FreeT(..) + -- * The free monad + , Free, free, runFree + -- * Operations + , liftF + , iterT + , iterTM + , hoistFreeT + , transFreeT + , joinFreeT + , cutoff + , partialIterT + , intersperseT + , intercalateT + , retractT + -- * Operations of free monad + , retract + , iter + , iterM + -- * Free Monads With Class + , MonadFree(..) + ) where + +import Control.Applicative +import Control.Monad (liftM, MonadPlus(..), join) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Trans.Class +import qualified Control.Monad.Fail as Fail +import Control.Monad.Free.Class +import Control.Monad.IO.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 hiding (join) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Traversable +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +import GHC.Generics + +-- | The base functor for a free monad. +data FreeF f a b = Pure a | Free (f b) + deriving (Eq,Ord,Show,Read,Data,Generic,Generic1) + +instance Show1 f => Show2 (FreeF f) where + liftShowsPrec2 spa _sla _spb _slb d (Pure a) = + showsUnaryWith spa "Pure" d a + liftShowsPrec2 _spa _sla spb slb d (Free as) = + showsUnaryWith (liftShowsPrec spb slb) "Free" d as + +instance (Show1 f, Show a) => Show1 (FreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (FreeF f) where + liftReadsPrec2 rpa _rla rpb rlb = readsData $ + readsUnaryWith rpa "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free + +instance (Read1 f, Read a) => Read1 (FreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (FreeF f) where + liftEq2 eq _ (Pure a) (Pure b) = eq a b + liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs + liftEq2 _ _ _ _ = False + +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (FreeF f) where + liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b + liftCompare2 _ _ (Pure _) (Free _) = LT + liftCompare2 _ _ (Free _) (Pure _) = GT + liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb + +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + liftCompare = liftCompare2 compare + +instance Functor f => Functor (FreeF f a) where + fmap _ (Pure a) = Pure a + fmap f (Free as) = Free (fmap f as) + {-# INLINE fmap #-} + +instance Foldable f => Foldable (FreeF f a) where + foldMap f (Free as) = foldMap f as + foldMap _ _ = mempty + {-# INLINE foldMap #-} + +instance Traversable f => Traversable (FreeF f a) where + traverse _ (Pure a) = pure (Pure a) + traverse f (Free as) = Free <$> traverse f as + {-# INLINE traverse #-} + +instance Functor f => Bifunctor (FreeF f) where + bimap f _ (Pure a) = Pure (f a) + bimap _ g (Free as) = Free (fmap g as) + {-# INLINE bimap #-} + +instance Foldable f => Bifoldable (FreeF f) where + bifoldMap f _ (Pure a) = f a + bifoldMap _ g (Free as) = foldMap g as + {-# INLINE bifoldMap #-} + +instance Traversable f => Bitraversable (FreeF f) where + bitraverse f _ (Pure a) = Pure <$> f a + bitraverse _ g (Free as) = Free <$> traverse g as + {-# INLINE bitraverse #-} + +transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b +transFreeF _ (Pure a) = Pure a +transFreeF t (Free as) = Free (t as) +{-# INLINE transFreeF #-} + +-- | The \"free monad transformer\" for an applicative @f@ +newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) } + +-- | The \"free monad\" for an applicative @f@. +type Free f = FreeT f Identity + +-- | Evaluates the first layer out of a free monad value. +runFree :: Free f a -> FreeF f a (Free f a) +runFree = runIdentity . runFreeT +{-# INLINE runFree #-} + +-- | Pushes a layer into a free monad value. +free :: FreeF f a (Free f a) -> Free f a +free = FreeT . Identity +{-# INLINE free #-} + +deriving instance + ( Typeable f, Typeable m + , Data (m (FreeF f a (FreeT f m a))) + , Data a + ) => Data (FreeT f m a) + +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where + (==) = eq1 + +instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where + liftEq eq = go + where + go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where + compare = compare1 + +instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where + liftCompare cmp = go + where + go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 f, Show1 m) => Show1 (FreeT f m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (FreeT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "FreeT" d x + +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where + showsPrec = showsPrec1 + +instance (Read1 f, Read1 m) => Read1 (FreeT f m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "FreeT" FreeT + +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where + readsPrec = readsPrec1 + +instance (Functor f, Functor m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (fmap f' m) where + f' (Pure a) = Pure (f a) + f' (Free as) = Free (fmap (fmap f) as) + +instance (Applicative f, Applicative m) => Applicative (FreeT f m) where + pure a = FreeT (pure (Pure a)) + {-# INLINE pure #-} + FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where + g (Pure f') (Pure a') = Pure (f' a') + g (Pure f') (Free as) = Free $ fmap f' <$> as + g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs + g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as + {-# INLINE (<*>) #-} + +instance (Apply f, Apply m) => Apply (FreeT f m) where + FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where + g (Pure f') (Pure a') = Pure (f' a') + g (Pure f') (Free as) = Free $ fmap f' <$> as + g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs + g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as + +instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where + FreeT m >>- f = FreeT $ m >>= \v -> case v of + Pure a -> runFreeT (f a) + Free w -> return (Free (fmap (>>- f) w)) + +instance (Applicative f, Monad m) => Monad (FreeT f m) where + return = pure + {-# INLINE return #-} + FreeT m >>= f = FreeT $ m >>= \v -> case v of + Pure a -> runFreeT (f a) + Free w -> return (Free (fmap (>>= f) w)) +#if !MIN_VERSION_base(4,13,0) + fail e = FreeT (fail e) +#endif + +instance (Applicative f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where + fail e = FreeT (Fail.fail e) + +instance Applicative f => MonadTrans (FreeT f) where + lift = FreeT . liftM Pure + {-# INLINE lift #-} + +instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (Applicative f, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Applicative f, MonadWriter w m) => MonadWriter w (FreeT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Pure x, w) = Pure (x, w) + concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y + pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) + g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance (Applicative f, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance (Applicative f, MonadError e m) => MonadError e (FreeT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f) + +instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where + callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) + +instance (Applicative f, MonadPlus m) => Alternative (FreeT f m) where + empty = FreeT mzero + FreeT ma <|> FreeT mb = FreeT (mplus ma mb) + {-# INLINE (<|>) #-} + +instance (Applicative f, MonadPlus m) => MonadPlus (FreeT f m) where + mzero = FreeT mzero + {-# INLINE mzero #-} + mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb) + {-# INLINE mplus #-} + +instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where + wrap = FreeT . return . Free + {-# INLINE wrap #-} + +instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance (Applicative 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 #-} + +-- | Given an applicative homomorphism from @f (m a)@ to @m a@, +-- tear down a free monad transformer using iteration. +iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a +iterT f (FreeT m) = do + val <- m + case fmap (iterT f) val of + Pure x -> return x + Free y -> f y + +-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@, +-- tear down a free monad transformer using iteration over a transformer. +iterTM :: (Applicative f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a +iterTM f (FreeT m) = do + val <- lift m + case fmap (iterTM f) val of + Pure x -> return x + Free y -> f y + +instance (Foldable m, Foldable f) => Foldable (FreeT f m) where + foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m + +instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where + traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m + +-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ +-- +-- @'hoistFreeT' :: ('Functor' m, 'Applicative' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ +hoistFreeT :: (Functor m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b +hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT + +-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ +transFreeT :: (Monad m, Applicative 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, Applicative 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' +-- +-- @ +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => Free f a -> f a +retract m = + case runIdentity (runFreeT m) of + Pure a -> return a + Free as -> as >>= retract + +-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration. +iter :: Applicative f => (f a -> a) -> Free f a -> a +iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) + +-- | Like 'iter' for monadic values. +iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a +iterM phi = iterT phi . hoistFreeT (return . runIdentity) + +-- | 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. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'cutoff' 0 _ ≡ 'return' 'Nothing' +-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' +-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' +-- 'cutoff' (n+1) '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('cutoff' n) +-- @ +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Applicative f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a) +cutoff n _ | n <= 0 = return Nothing +cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m + +-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@. +-- This is sort of the opposite for @'cutoff'@. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'partialIterT' 0 _ m ≡ m +-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return' +-- 'partialIterT' (n+1) phi '.' 'lift' ≡ 'lift' +-- 'partialIterT' (n+1) phi '.' 'wrap' ≡ 'join' . 'lift' . phi +-- @ +partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b +partialIterT n phi m + | n <= 0 = m + | otherwise = FreeT $ do + val <- runFreeT m + case val of + Pure a -> return (Pure a) + Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi + +-- | @intersperseT f m@ inserts a layer @f@ between every two layers in +-- @m@. +-- +-- @ +-- 'intersperseT' f '.' 'return' ≡ 'return' +-- 'intersperseT' f '.' 'lift' ≡ 'lift' +-- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap')) +-- @ +intersperseT :: (Monad m, Applicative f) => f a -> FreeT f m b -> FreeT f m b +intersperseT f (FreeT m) = FreeT $ do + val <- m + case val of + Pure x -> return $ Pure x + Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y + +-- | Tear down a free monad transformer using Monad instance for @t m@. +retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a +retractT (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= retractT + +-- | @intercalateT f m@ inserts a layer @f@ between every two layers in +-- @m@ and then retracts the result. +-- +-- @ +-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f +-- @ +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Free.Church +-- Copyright : (C) 2008-2014 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : non-portable (rank-2 polymorphism, MTPCs) +-- +-- Church-encoded free monad transformer. +-- +----------------------------------------------------------------------------- +module Control.Monad.Trans.Free.Church + ( + -- * The free monad transformer + FT(..) + -- * The free monad + , F, free, runF + -- * Operations + , improveT + , toFT, fromFT + , iterT + , iterTM + , hoistFT + , transFT + , joinFT + , cutoff + -- * Operations of free monad + , improve + , fromF, toF + , retract + , retractT + , iter + , iterM + -- * Free Monads With Class + , MonadFree(..) + , liftF + ) where + +import Control.Applicative +import Control.Category ((<<<), (>>>)) +import Control.Monad +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Identity +import Control.Monad.Trans.Class +import Control.Monad.IO.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 Control.Monad.Free.Class +import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free) +import qualified Control.Monad.Trans.Free as FreeT +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Functor.Bind hiding (join) +import Data.Functor.Classes + +-- | The \"free monad transformer\" for a functor @f@ +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, Eq1 f, Eq1 m) => Eq1 (FT f m) where + liftEq eq x y = liftEq eq (fromFT x) (fromFT y) + +instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where + liftCompare cmp x y= liftCompare cmp (fromFT x) (fromFT y) + +instance (Functor f, Monad m, Eq1 f, Eq1 m, Eq a) => Eq (FT f m a) where + (==) = eq1 + +instance (Functor f, Monad m, Ord1 f, Ord1 m, Ord a) => Ord (FT f m a) where + compare = compare1 + +instance Functor (FT f m) where + fmap f (FT k) = FT $ \a fr -> k (a . f) fr + +instance Apply (FT f m) where + (<.>) = (<*>) + +instance Applicative (FT f m) where + pure a = FT $ \k _ -> k a + FT fk <*> FT ak = FT $ \b fr -> fk (\e -> ak (\d -> b (e d)) fr) fr + +instance Bind (FT f m) where + (>>-) = (>>=) + +instance Monad (FT f m) where + return = pure + FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr + +instance Fail.MonadFail m => Fail.MonadFail (FT f m) where + fail = lift . Fail.fail + {-# INLINE fail #-} + +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) + +instance Alternative m => Alternative (FT f m) where + empty = FT (\_ _ -> empty) + FT k1 <|> FT k2 = FT $ \a fr -> k1 a fr <|> k2 a fr + +instance MonadPlus m => MonadPlus (FT f m) where + mzero = FT (\_ _ -> mzero) + mplus (FT k1) (FT k2) = FT $ \a fr -> k1 a fr `mplus` k2 a fr + +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) (\xg xf -> F.foldr (liftM2 (<<<) . xg) (return id) xf) + {-# INLINE foldr #-} + + foldl' f z xs = F.foldl' (!>>>) id inner z + where + (!>>>) h g = \r -> g $! h r + inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf) + {-# INLINE foldl' #-} + +instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where + traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree + where + traversePure = return . fmap return . f + traverseFree xg = return . fmap (wrap . fmap (join . lift)) . T.traverse (T.sequenceA . xg) + +instance (MonadIO m) => MonadIO (FT f m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (Functor f, MonadError e m) => MonadError e (FT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + m `catchError` f = toFT $ fromFT m `catchError` (fromFT . f) + +instance MonadCont m => MonadCont (FT f m) where + callCC f = join . lift $ callCC (\k -> return $ f (lift . k . return)) + +instance MonadReader r m => MonadReader r (FT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFT (local f) + {-# INLINE local #-} + +instance (Functor f, MonadWriter w m) => MonadWriter w (FT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen = toFT . listen . fromFT + pass = toFT . pass . fromFT + writer w = lift (writer w) + {-# INLINE writer #-} + +instance MonadState s m => MonadState s (FT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +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 => 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 (\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) (\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) (\xg -> return . kf . fmap (runIdentity . xg)) + +-- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor. +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 (\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) (\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) => (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 :: (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. +-- +-- Some examples (n ≥ 0): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling 'retract . cutoff n' is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Functor f, Monad m) => Integer -> FT f m a -> FT f m (Maybe a) +cutoff n = toFT . FreeT.cutoff n . fromFT + +-- | +-- 'retract' is the left inverse of 'liftF' +-- +-- @ +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => F f a -> f a +retract m = runF m return join +{-# INLINE retract #-} + +-- | 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) (\xg xf -> return $ xf >>= join . lift . xg) + +-- | Tear down an 'F' 'Monad' using iteration. +iter :: Functor f => (f a -> a) -> F f a -> a +iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) +{-# INLINE iter #-} + +-- | Like 'iter' for monadic values. +iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> F f a -> m a +iterM phi = iterT phi . hoistFT (return . runIdentity) + +-- | Convert to another free monad representation. +fromF :: (Functor f, MonadFree f m) => F f a -> m a +fromF m = runF m return wrap +{-# INLINE fromF #-} + +-- | Generate a Church-encoded free monad from a 'Free' monad. +toF :: Free f a -> F f a +toF = toFT +{-# INLINE toF #-} + +-- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes. +-- +-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: +-- +-- +-- +-- +-- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: +-- +-- +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 #-} + diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Iter.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Iter +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Based on +-- +-- Unlike 'Free', this is a true monad transformer. +---------------------------------------------------------------------------- +module Control.Monad.Trans.Iter + ( + -- | + -- Functions in Haskell are meant to be pure. For example, if an expression + -- has type Int, there should exist a value of the type such that the expression + -- can be replaced by that value in any context without changing the meaning + -- of the program. + -- + -- Some computations may perform side effects (@unsafePerformIO@), throw an + -- exception (using @error@); or not terminate + -- (@let infinity = 1 + infinity in infinity@). + -- + -- While the 'IO' monad encapsulates side-effects, and the 'Either' + -- monad encapsulates errors, the 'Iter' monad encapsulates + -- non-termination. The 'IterT' transformer generalizes non-termination to any monadic + -- computation. + -- + -- Computations in 'IterT' (or 'Iter') can be composed in two ways: + -- + -- * /Sequential:/ Using the 'Monad' instance, the result of a computation + -- can be fed into the next. + -- + -- * /Parallel:/ Using the 'MonadPlus' instance, several computations can be + -- executed concurrently, and the first to finish will prevail. + -- See also the . + + -- * The iterative monad transformer + IterT(..) + -- * Capretta's iterative monad + , Iter, iter, runIter + -- * Combinators + , delay + , hoistIterT + , liftIter + , cutoff + , never + , untilJust + , interleave, interleave_ + -- * Consuming iterative monads + , retract + , fold + , foldM + -- * IterT ~ FreeT Identity + , MonadFree(..) + -- * Examples + -- $examples + ) 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 +import qualified Control.Monad.Fail as Fail +import Control.Monad.Free.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.Cont.Class +import Control.Monad.IO.Class +import Data.Bifunctor +import Data.Bitraversable +import Data.Either +import Data.Functor.Bind hiding (join) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Typeable +import Data.Data + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +-- | The monad supporting iteration based over a base monad @m@. +-- +-- @ +-- 'IterT' ~ 'FreeT' 'Identity' +-- @ +newtype IterT m a = IterT { runIterT :: m (Either a (IterT m a)) } + +-- | Plain iterative computations. +type Iter = IterT Identity + +-- | Builds an iterative computation from one first step. +-- +-- prop> runIter . iter == id +iter :: Either a (Iter a) -> Iter a +iter = IterT . Identity +{-# INLINE iter #-} + +-- | Executes the first step of an iterative computation +-- +-- prop> iter . runIter == id +runIter :: Iter a -> Either a (Iter a) +runIter = runIdentity . runIterT +{-# INLINE runIter #-} + +instance (Eq1 m) => Eq1 (IterT m) where + liftEq eq = go + where + go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y + +instance (Eq1 m, Eq a) => Eq (IterT m a) where + (==) = eq1 + +instance (Ord1 m) => Ord1 (IterT m) where + liftCompare cmp = go + where + go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Ord1 m, Ord a) => Ord (IterT m a) where + compare = compare1 + +instance (Show1 m) => Show1 (IterT m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (IterT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "IterT" d x + +instance (Show1 m, Show a) => Show (IterT m a) where + showsPrec = showsPrec1 + +instance (Read1 m) => Read1 (IterT m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "IterT" IterT + +instance (Read1 m, Read a) => Read (IterT m a) where + readsPrec = readsPrec1 + +instance Monad m => Functor (IterT m) where + fmap f = IterT . liftM (bimap f (fmap f)) . runIterT + {-# INLINE fmap #-} + +instance Monad m => Applicative (IterT m) where + pure = IterT . return . Left + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (IterT m) where + return = pure + {-# INLINE return #-} + IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k)) + {-# INLINE (>>=) #-} +#if !MIN_VERSION_base(4,13,0) + fail = Fail.fail + {-# INLINE fail #-} +#endif + +instance Monad m => Fail.MonadFail (IterT m) where + fail _ = never + {-# INLINE fail #-} + +instance Monad m => Apply (IterT m) where + (<.>) = ap + {-# INLINE (<.>) #-} + +instance Monad m => Bind (IterT m) where + (>>-) = (>>=) + {-# INLINE (>>-) #-} + +instance MonadFix m => MonadFix (IterT m) where + mfix f = IterT $ mfix $ runIterT . f . either id (error "mfix (IterT m): Right") + {-# INLINE mfix #-} + +instance Monad m => Alternative (IterT m) where + empty = mzero + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +-- | Capretta's 'race' combinator. Satisfies left catch. +instance Monad m => MonadPlus (IterT m) where + mzero = never + {-# INLINE mzero #-} + (IterT x) `mplus` (IterT y) = IterT $ x >>= either + (return . Left) + (flip liftM y . second . mplus) + {-# INLINE mplus #-} + +instance MonadTrans IterT where + lift = IterT . liftM Left + {-# INLINE lift #-} + +instance Foldable m => Foldable (IterT m) where + foldMap f = foldMap (either f (foldMap f)) . runIterT + {-# INLINE foldMap #-} + +instance Foldable1 m => Foldable1 (IterT m) where + foldMap1 f = foldMap1 (either f (foldMap1 f)) . runIterT + {-# INLINE foldMap1 #-} + +instance (Monad m, Traversable m) => Traversable (IterT m) where + traverse f (IterT m) = IterT <$> traverse (bitraverse f (traverse f)) m + {-# INLINE traverse #-} + +instance (Monad m, Traversable1 m) => Traversable1 (IterT m) where + traverse1 f (IterT m) = IterT <$> traverse1 go m where + go (Left a) = Left <$> f a + go (Right a) = Right <$> traverse1 f a + {-# INLINE traverse1 #-} + +instance MonadReader e m => MonadReader e (IterT m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistIterT (local f) + {-# INLINE local #-} + +instance MonadWriter w m => MonadWriter w (IterT m) where + tell = lift . tell + {-# INLINE tell #-} + listen (IterT m) = IterT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Left x, w) = Left (x, w) + concat' (Right y, w) = Right $ second (w `mappend`) <$> y + pass m = IterT . pass' . runIterT . hoistIterT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Left ((x, f), w)) = tell (f w) >> return (Left x) + g (Right f) = return . Right . IterT . pass' . runIterT $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance MonadState s m => MonadState s (IterT m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance MonadError e m => MonadError e (IterT m) where + throwError = lift . throwError + {-# INLINE throwError #-} + IterT m `catchError` f = IterT $ liftM (fmap (`catchError` f)) m `catchError` (runIterT . f) + +instance MonadIO m => MonadIO (IterT m) where + liftIO = lift . liftIO + +instance MonadCont m => MonadCont (IterT m) where + callCC f = IterT $ callCC (\k -> runIterT $ f (lift . k . Left)) + +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 (`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 +-- computation require one more step, without changing its final +-- result. +-- +-- prop> runIter (delay ma) == Right ma +delay :: (Monad f, MonadFree f m) => m a -> m a +delay = wrap . return +{-# INLINE delay #-} + +-- | +-- 'retract' is the left inverse of 'lift' +-- +-- @ +-- 'retract' . 'lift' = 'id' +-- @ +retract :: Monad m => IterT m a -> m a +retract m = runIterT m >>= either return retract + +-- | Tear down a 'Free' 'Monad' using iteration. +fold :: Monad m => (m a -> a) -> IterT m a -> a +fold phi (IterT m) = phi (either id (fold phi) `liftM` m) + +-- | Like 'fold' with monadic result. +foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a +foldM phi (IterT m) = phi (either return (foldM phi) `liftM` m) + +-- | Lift a monad homomorphism from @m@ to @n@ into a Monad homomorphism from @'IterT' m@ to @'IterT' n@. +hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b +hoistIterT f (IterT as) = IterT (fmap (hoistIterT f) `liftM` f as) + +-- | Lifts a plain, non-terminating computation into a richer environment. +-- 'liftIter' is a 'Monad' homomorphism. +liftIter :: (Monad m) => Iter a -> IterT m a +liftIter = hoistIterT (return . runIdentity) + +-- | A computation that never terminates +never :: (Monad f, MonadFree f m) => m a +never = delay never + +-- | Repeatedly run a computation until it produces a 'Just' value. +-- This can be useful when paired with a monad that has side effects. +-- +-- For example, we may have @genId :: IO (Maybe Id)@ that uses a random +-- number generator to allocate ids, but fails if it finds a collision. +-- We can repeatedly run this with +-- +-- @ +-- 'retract' ('untilJust' genId) :: IO Id +-- @ +untilJust :: (Monad m) => m (Maybe a) -> IterT m a +untilJust f = maybe (delay (untilJust f)) return =<< lift f +{-# INLINE untilJust #-} + +-- | Cuts off an iterative computation after a given number of +-- steps. If the number of steps is 0 or less, no computation nor +-- monadic effects will take place. +-- +-- The step where the final value is produced also counts towards the limit. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'cutoff' 0 _ ≡ 'return' 'Nothing' +-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' +-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' +-- 'cutoff' (n+1) '.' 'delay' ≡ 'delay' . 'cutoff' n +-- 'cutoff' n 'never' ≡ 'iterate' 'delay' ('return' 'Nothing') '!!' n +-- @ +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Monad m) => Integer -> IterT m a -> IterT m (Maybe a) +cutoff n | n <= 0 = const $ return Nothing +cutoff n = IterT . liftM (either (Left . Just) + (Right . cutoff (n - 1))) . runIterT + +-- | Interleaves the steps of a finite list of iterative computations, and +-- collects their results. +-- +-- The resulting computation has as many steps as the longest computation +-- in the list. +interleave :: Monad m => [IterT m a] -> IterT m [a] +interleave ms = IterT $ do + xs <- mapM runIterT ms + if null (rights xs) + then return . Left $ lefts xs + else return . Right . interleave $ map (either return id) xs +{-# INLINE interleave #-} + +-- | Interleaves the steps of a finite list of computations, and discards their +-- results. +-- +-- The resulting computation has as many steps as the longest computation +-- in the list. +-- +-- Equivalent to @'void' '.' 'interleave'@. +interleave_ :: (Monad m) => [IterT m a] -> IterT m () +interleave_ [] = return () +interleave_ xs = IterT $ liftM (Right . interleave_ . rights) $ mapM runIterT xs +{-# INLINE interleave_ #-} + +instance (Monad m, Semigroup a, Monoid a) => Monoid (IterT m a) where + mempty = return mempty + mappend = (<>) + mconcat = mconcat' . map Right + where + mconcat' :: (Monad m, Monoid a) => [Either a (IterT m a)] -> IterT m a + mconcat' ms = IterT $ do + xs <- mapM (either (return . Left) runIterT) ms + case compact xs of + [l@(Left _)] -> return l + xs' -> return . Right $ mconcat' xs' + {-# INLINE mconcat' #-} + + compact :: (Monoid a) => [Either a b] -> [Either a b] + compact [] = [] + compact (r@(Right _):xs) = r:(compact xs) + compact ( Left a :xs) = compact' a xs + + compact' a [] = [Left a] + compact' a (r@(Right _):xs) = (Left a):(r:(compact xs)) + compact' a ( (Left a'):xs) = compact' (a `mappend` a') xs + +instance (Monad m, Semigroup a) => Semigroup (IterT m a) where + x <> y = IterT $ do + x' <- runIterT x + y' <- runIterT y + case (x', y') of + ( Left a, Left b) -> return . Left $ a <> b + ( Left a, Right b) -> return . Right $ liftM (a <>) b + (Right a, Left b) -> return . Right $ liftM (<> b) a + (Right a, Right b) -> return . Right $ a <> b + +deriving instance + ( Typeable m + , Data (m (Either a (IterT m a))) + , Data a + ) => Data (IterT m a) + +{- $examples + +* + +* + +-} diff --git a/src/Control/MonadPlus/Free.hs b/src/Control/MonadPlus/Free.hs deleted file mode 100644 --- a/src/Control/MonadPlus/Free.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.MonadPlus.Free --- Copyright : (C) 2008-2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : MPTCs, fundeps --- --- left-distributive MonadPlus for free. ----------------------------------------------------------------------------- -module Control.MonadPlus.Free - ( MonadFree(..) - , Free(..) - , retract - , liftF - , iter - , iterM - , 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. --- --- <> -data Free f a - = Pure a - | Free (f (Free f a)) - | Plus [Free f a] -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable) -#endif - -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 #-} - -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 #-} - --- | Like iter for monadic values. -iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> ([m a] -> m a) -> Free f a -> m a -iterM phi psi = go where - go (Pure a) = return a - go (Free as) = phi (go <$> as) - go (Plus as) = psi (go <$> as) - --- | 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) - -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 -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