packages feed

free 3.4.2 → 5.2

raw patch · 44 files changed

Files

− .ghci 
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -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.*
+ .hlint.yaml view
@@ -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}
− .travis.yml 
@@ -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}"
CHANGELOG.markdown view
@@ -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`.
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2008-2012 Edward Kmett+Copyright 2008-2013 Edward Kmett  All rights reserved.
README.markdown view
@@ -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.
+ doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md view
@@ -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.
+ doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md view
@@ -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.
+ doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md view
@@ -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`.
+ doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md view
@@ -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+<concatenation> ≡ 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+<concatenation> ≡ 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 :<n) (c :< p))) ==++\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 ->+   (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)++```+ +
+ doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md view
@@ -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).
+ doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md view
@@ -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)+```++++
+ doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md view
@@ -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)++.+```
+ examples/Cabbage.lhs view
@@ -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)+@
+ examples/LICENSE view
@@ -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.
+ examples/MandelbrotIter.lhs view
@@ -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 <https://en.wikipedia.org/wiki/Mandelbrot_set Mandelbrot set>,+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"+
+ examples/NewtonCoiter.lhs view
@@ -0,0 +1,100 @@+Many numerical approximation methods compute infinite sequences of results; each,+hopefully, more accurate than the previous one.++<https://en.wikipedia.org/wiki/Newton's_method Newton's method>+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+
+ examples/PerfTH.hs view
@@ -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"+
+ examples/RetryTH.hs view
@@ -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
+ examples/Teletype.lhs view
@@ -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.+
+ examples/ValidationForm.hs view
@@ -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 ++ "\"!"+
+ examples/free-examples.cabal view
@@ -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 <ekmett@gmail.com>+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
free.cabal view
@@ -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 <ekmett@gmail.com> 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:+  <https://ekmett.github.io/reader/2008/monads-for-free/>+  <https://ekmett.github.io/reader/2011/free-monads-for-less/>  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
src/Control/Alternative/Free.hs view
@@ -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 #-}
+ src/Control/Alternative/Free/Final.hs view
@@ -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 <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- Final encoding of free 'Alternative' functors.+----------------------------------------------------------------------------+module Control.Alternative.Free.Final+  ( Alt(..)+  , runAlt+  , liftAlt+  , hoistAlt+  ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Functor.Alt ((<!>))+import qualified Data.Functor.Alt as Alt++#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))+
src/Control/Applicative/Free.hs view
@@ -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 <ekmett@gmail.com>@@ -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 <http://arxiv.org/abs/1403.0749 Free Applicative Functors>,+  -- 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+<examples/ValidationForm.hs Validation form>++-}
+ src/Control/Applicative/Free/Fast.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------+-- |+-- A faster free applicative.+-- Based on <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work>.+--------------------------------------------------------------------------------+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
+ src/Control/Applicative/Free/Final.hs view
@@ -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 <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- Final encoding of free 'Applicative' functors.+----------------------------------------------------------------------------+module Control.Applicative.Free.Final+  (+  -- | Compared to the free monad, they are less expressive. However, they are also more+  -- flexible to inspect and interpret, as the number of ways in which+  -- the values can be nested is more limited.++    Ap(..)+  , runAp+  , runAp_+  , liftAp+  , hoistAp+  , retractAp++  -- * Examples+  -- $examples+  ) where++import Control.Applicative+import Data.Functor.Apply++-- | The free 'Applicative' for a 'Functor' @f@.+newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a }++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp phi m = _runAp m phi++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)++instance Functor (Ap f) where+  fmap f (Ap g) = Ap (\k -> fmap f (g k))++instance Apply (Ap f) where+  Ap f <.> Ap x = Ap (\k -> f k <*> x k)++instance Applicative (Ap f) where+  pure x = Ap (\_ -> pure x)+  Ap f <*> Ap x = Ap (\k -> f k <*> x k)++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAp :: f a -> Ap f a+liftAp x = Ap (\k -> k x)++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b+hoistAp f (Ap g) = Ap (\k -> g (k . f))++-- | Interprets the free applicative functor over f using the semantics for+--   `pure` and `<*>` given by the Applicative instance for f.+--+--   prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp (Ap g) = g id++{- $examples++<examples/ValidationForm.hs Validation form>++-}
+ src/Control/Applicative/Trans/Free.hs view
@@ -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 <ekmett@gmail.com>+-- 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 <http://paolocapriotti.com/assets/applicative.pdf Free Applicative Functors>,+  -- 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
src/Control/Comonad/Cofree.hs view
@@ -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 <ekmett@gmail.com>@@ -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+-- <http://www.cs.appstate.edu/~johannp/jfp06-revised.pdf Monadic Augment and Generalised Shortcut Fusion> by Neil Ghani et al., Section 4.3+-- for more details.+--+-- In particular, if @f a ≡ [a]@, the+-- resulting data structure is a <https://en.wikipedia.org/wiki/Rose_tree Rose tree>.+-- For a practical application, check+-- <https://web.archive.org/web/20161208002902/http://www.cs.le.ac.uk/people/ak155/Papers/CALCO-07/GK07.pdf Higher Dimensional Trees, Algebraically> 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 #-}
src/Control/Comonad/Cofree/Class.hs view
@@ -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
src/Control/Comonad/Trans/Cofree.hs view
@@ -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 <ekmett@gmail.com>@@ -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
+ src/Control/Comonad/Trans/Coiter.hs view
@@ -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 <ekmett@gmail.com>+-- 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++<examples/NewtonCoiter.lhs Newton's method>++-}
src/Control/Monad/Free.hs view
@@ -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 <ekmett@gmail.com>@@ -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 (<http://hackage.haskell.org/package/kan-extensions>). -- -- 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
+ src/Control/Monad/Free/Ap.hs view
@@ -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+--+-- * <http://elvishjerricco.github.io/2016/04/08/applicative-effects-in-free-monads.html Applicative Effects in Free Monads>+--+-- * <http://elvishjerricco.github.io/2016/04/13/more-on-applicative-effects-in-free-monads.html More on Applicative Effects in Free Monads>+--------------------------------------------------------------------------------+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 #-}
src/Control/Monad/Free/Church.hs view
@@ -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 <ekmett@gmail.com>@@ -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. ----- <http://comonad.com/reader/2011/free-monads-for-less/>--- <http://comonad.com/reader/2011/free-monads-for-less-2/>+-- 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:+--+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less/   Free monads for less — Part 1>+--+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> ---------------------------------------------------------------------------- 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'. ----- <http://comonad.com/reader/2011/free-monads-for-less-2/>+-- <https://ekmett.github.io/reader/2011/free-monads-for-less-2/> 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: ----- <http://comonad.com/reader/2011/free-monads-for-less/>--- <http://comonad.com/reader/2011/free-monads-for-less-2/>+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less/   Free monads for less — Part 1> ----- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer:+-- * <https://ekmett.github.io/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> ----- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>+-- and <http://www.iai.uni-bonn.de/~jv/mpc08.pdf \"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 #-}+++-- | 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)
src/Control/Monad/Free/Class.hs view
@@ -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 <ekmett@gmail.com>@@ -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 (<http://hackage.haskell.org/package/kan-extensions>). -- -- 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
+ src/Control/Monad/Free/TH.hs view
@@ -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 <ekmett@gmail.com>+-- 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++<examples/Teletype.lhs Teletype> (regular data type declaration)++<examples/RetryTH.hs Retry> (GADT declaration)++-}
src/Control/Monad/Trans/Free.hs view
@@ -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 <ekmett@gmail.com>@@ -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)
+ src/Control/Monad/Trans/Free/Ap.hs view
@@ -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)
+ src/Control/Monad/Trans/Free/Church.hs view
@@ -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 <ekmett@gmail.com>+-- 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:+--+-- <https://ekmett.github.io/reader/2011/free-monads-for-less/>+-- <https://ekmett.github.io/reader/2011/free-monads-for-less-2/>+--+-- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer:+--+-- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>+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 #-}+
+ src/Control/Monad/Trans/Iter.hs view
@@ -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 <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  MPTCs, fundeps+--+-- Based on <http://www.ioc.ee/~tarmo/tday-veskisilla/uustalu-slides.pdf Capretta's Iterative Monad Transformer>+--+-- 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 <examples/Cabbage.lhs cabbage example>.++  -- * 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++* <examples/MandelbrotIter.lhs Rendering the Mandelbrot set>++* <examples/Cabbage.lhs The wolf, the sheep and the cabbage>++-}
− src/Control/MonadPlus/Free.hs 
@@ -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 <ekmett@gmail.com>--- 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.------ <<http://www.haskell.org/haskellwiki/MonadPlus>>-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