free 5.1.9 → 5.1.10
raw patch · 45 files changed
+8982/−8973 lines, 45 filesdep ~semigroupoidsdep ~template-haskelldep ~th-abstractionsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: semigroupoids, template-haskell, th-abstraction
API changes (from Hackage documentation)
+ Control.Monad.Trans.Free.Church: instance Control.Monad.Fail.MonadFail m => Control.Monad.Fail.MonadFail (Control.Monad.Trans.Free.Church.FT f m)
Files
- .gitignore +32/−32
- .hlint.yaml +15/−15
- .vim.custom +31/−31
- CHANGELOG.markdown +228/−224
- LICENSE +30/−30
- README.markdown +15/−15
- Setup.lhs +7/−7
- doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md +6/−6
- doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md +6/−6
- doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md +9/−9
- doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md +612/−612
- doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md +200/−200
- doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md +88/−88
- doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md +448/−448
- examples/Cabbage.lhs +209/−209
- examples/LICENSE +30/−30
- examples/MandelbrotIter.lhs +137/−137
- examples/NewtonCoiter.lhs +102/−102
- examples/PerfTH.hs +122/−122
- examples/RetryTH.hs +96/−96
- examples/Teletype.lhs +106/−106
- examples/ValidationForm.hs +117/−117
- examples/free-examples.cabal +121/−121
- free.cabal +166/−166
- include/free-common.h +23/−23
- src/Control/Alternative/Free.hs +164/−164
- src/Control/Alternative/Free/Final.hs +73/−73
- src/Control/Applicative/Free.hs +144/−144
- src/Control/Applicative/Free/Fast.hs +169/−169
- src/Control/Applicative/Free/Final.hs +91/−91
- src/Control/Applicative/Trans/Free.hs +233/−233
- src/Control/Comonad/Cofree.hs +507/−507
- src/Control/Comonad/Cofree/Class.hs +60/−60
- src/Control/Comonad/Trans/Cofree.hs +352/−352
- src/Control/Comonad/Trans/Coiter.hs +265/−265
- src/Control/Monad/Free.hs +503/−503
- src/Control/Monad/Free/Ap.hs +449/−449
- src/Control/Monad/Free/Church.hs +253/−253
- src/Control/Monad/Free/Class.hs +170/−170
- src/Control/Monad/Free/TH.hs +475/−475
- src/Control/Monad/Trans/Free.hs +612/−612
- src/Control/Monad/Trans/Free/Ap.hs +600/−600
- src/Control/Monad/Trans/Free/Church.hs +338/−333
- src/Control/Monad/Trans/Iter.hs +523/−523
- src/Data/Functor/Classes/Compat.hs +45/−45
.gitignore view
@@ -1,32 +1,32 @@-dist-dist-newstyle-docs-wiki-TAGS-tags-wip-.DS_Store-.*.swp-.*.swo-*.o-*.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.*+dist +dist-newstyle +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.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
@@ -1,15 +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}+- 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}
.vim.custom view
@@ -1,31 +1,31 @@-" Add the following to your .vimrc to automatically load this on startup--" if filereadable(".vim.custom")-" so .vim.custom-" endif--function StripTrailingWhitespace()- let myline=line(".")- let mycolumn = col(".")- silent %s/ *$//- call cursor(myline, mycolumn)-endfunction--" enable syntax highlighting-syntax on--" search for the tags file anywhere between here and /-set tags=TAGS;/--" highlight tabs and trailing spaces-set listchars=tab:‗‗,trail:‗-set list--" f2 runs hasktags-map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>--" strip trailing whitespace before saving-" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()--" rebuild hasktags after saving-au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"+" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
CHANGELOG.markdown view
@@ -1,224 +1,228 @@-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`.-* Added `iterM`--3.4.1-------* Added support for GHC 7.7's polykinded `Typeable`--3.4-----* Added instance `MonadFree f (ContT r m)`--3.3.1-------* Refactored build system-* Removed upper bounds on my own intra-package dependencies--3.3-----* Added `Control.Alternative.Free` and `Control.MonadPlus.Free`--3.2-----* Added `Control.Free.Applicative`-* Moved `Control.Monad.Free.Church` from `kan-extensions` into this package.+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`. +* Added `iterM` + +3.4.1 +----- +* Added support for GHC 7.7's polykinded `Typeable` + +3.4 +--- +* Added instance `MonadFree f (ContT r m)` + +3.3.1 +----- +* Refactored build system +* Removed upper bounds on my own intra-package dependencies + +3.3 +--- +* Added `Control.Alternative.Free` and `Control.MonadPlus.Free` + +3.2 +--- +* Added `Control.Free.Applicative` +* Moved `Control.Monad.Free.Church` from `kan-extensions` into this package.
LICENSE view
@@ -1,30 +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.+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.
README.markdown view
@@ -1,15 +1,15 @@-free-====--[](https://hackage.haskell.org/package/free) [](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.--Contact Information----------------------Contributions and bug reports are welcome!--Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.---Edward Kmett+free +==== + +[](https://hackage.haskell.org/package/free) [](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. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell-> module Main (main) where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md view
@@ -1,6 +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.+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
@@ -1,6 +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.+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
@@ -1,9 +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`.+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
@@ -1,612 +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)--```- -+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
@@ -1,200 +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).+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
@@ -1,88 +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)-```----+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
@@ -1,448 +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)--.-```+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
@@ -1,209 +1,209 @@-> {-# 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)-> import Prelude ()-> import Prelude.Compat--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)-@+> {-# 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) +> import Prelude () +> import Prelude.Compat + +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
@@ -1,30 +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.+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
@@ -1,137 +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"-+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
@@ -1,102 +1,102 @@-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)-> import Prelude-> import Prelude.Compat ()--> 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-+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) +> import Prelude +> import Prelude.Compat () + +> 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
@@ -1,122 +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"-+{-# 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
@@ -1,96 +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.Compat (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+{-# 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.Compat (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
@@ -1,106 +1,106 @@-> {-# 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 Prelude ()-> import Prelude.Compat-> 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.-+> {-# 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 Prelude () +> import Prelude.Compat +> 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
@@ -1,117 +1,117 @@-{-# LANGUAGE CPP #-}-module Main where--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif-import Control.Applicative.Free-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.State--import Data.Monoid (Sum(..))--import Text.Read.Compat (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 ++ "\"!"-+{-# LANGUAGE CPP #-} +module Main where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif +import Control.Applicative.Free +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State + +import Data.Monoid (Sum(..)) + +import Text.Read.Compat (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
@@ -1,121 +1,121 @@-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 == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , 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.2-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.*,- base-compat >= 0.6,- 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:- -- This unusually restrictive lower version bound on base is a workaround- -- for the fact that X11-1.10 does not build correctly on older versions of- -- base (see https://github.com/ekmett/free/runs/3235998897#step:18:237)- 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.*,- base-compat >= 0.6,- 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.*,- fail == 4.9.*,- 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.*,- base-compat >= 0.6,- fail == 4.9.*,- 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.*,- base-compat >= 0.6,- free,- monad-loops--executable free-validation-form- hs-source-dirs: .- default-language: Haskell2010- main-is: ValidationForm.hs- ghc-options: -Wall- build-depends:- base == 4.*,- base-compat >= 0.6,- free,- transformers >= 0.2 && < 0.7+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 == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , 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.2 +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.*, + base-compat >= 0.6, + 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: + -- This unusually restrictive lower version bound on base is a workaround + -- for the fact that X11-1.10 does not build correctly on older versions of + -- base (see https://github.com/ekmett/free/runs/3235998897#step:18:237) + 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.*, + base-compat >= 0.6, + 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.*, + fail == 4.9.*, + 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.*, + base-compat >= 0.6, + fail == 4.9.*, + 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.*, + base-compat >= 0.6, + free, + monad-loops + +executable free-validation-form + hs-source-dirs: . + default-language: Haskell2010 + main-is: ValidationForm.hs + ghc-options: -Wall + build-depends: + base == 4.*, + base-compat >= 0.6, + free, + transformers >= 0.2 && < 0.7
free.cabal view
@@ -1,166 +1,166 @@-name: free-category: Control, Monads-version: 5.1.9-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 == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , 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.2-synopsis: Monads for free-description:- Free monads are useful for many tree-like structures and domain specific languages.- .- 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 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.- .- More information on free monads, including examples, can be found in the- following blog posts:- <http://comonad.com/reader/2008/monads-for-free/>- <http://comonad.com/reader/2011/free-monads-for-less/>--build-type: Simple-extra-source-files:- .ghci- .gitignore- .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- include/free-common.h-extra-doc-files:- examples/*.hs- examples/*.lhs--source-repository head- type: git- location: git://github.com/ekmett/free.git--library- hs-source-dirs: src- include-dirs: include- includes: free-common.h-- default-language: Haskell2010- default-extensions: CPP- other-extensions:- MultiParamTypeClasses- FunctionalDependencies- FlexibleInstances- UndecidableInstances- Rank2Types- GADTs-- build-depends:- base >= 4.5 && < 5,- comonad >= 5.0.8 && < 6,- containers >= 0.3 && < 0.7,- distributive >= 0.5.2 && < 1,- exceptions >= 0.10.4 && < 0.11,- indexed-traversable >= 0.1.1 && < 0.2,- semigroupoids >= 5.3.5 && < 6,- th-abstraction >= 0.4.2.0 && < 0.5,- transformers >= 0.3 && < 0.7,- transformers-base >= 0.4.5.2 && < 0.5,- template-haskell >= 2.7.0.0 && < 2.19-- -- GHC-7.8 bundles transformers-0.3,- -- mtl-2.2.* requires transformers >=0.4- if impl(ghc >=7.10)- build-depends:- mtl >= 2.2.2 && < 2.4- else- build-depends:- mtl >= 2.1.3.1 && < 2.4-- -- recent profunctors dropped support for GHCs older than 7.8- if impl(ghc >=7.8)- build-depends:- profunctors >= 5.6.1 && < 6- else- build-depends:- profunctors >= 5.2.2 && < 5.3-- if !impl(ghc >= 8.2)- build-depends: bifunctors >= 5.5.9 && < 6-- if !impl(ghc >= 8.0)- build-depends: semigroups >= 0.18.5 && < 1-- -- Ensure Data.Functor.Classes is always available- if impl(ghc >= 7.10)- build-depends: transformers >= 0.4.2.0- else- build-depends: transformers-compat >= 0.5.1.0 && <0.8-- 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.Monad.Trans.Free.Ap- Control.Monad.Trans.Free.Church- Control.Monad.Trans.Iter-- other-modules:- Data.Functor.Classes.Compat-- ghc-options: -Wall-- -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances-- if !impl(ghc >= 8.8)- ghc-options: -Wnoncanonical-monadfail-instances- else- build-depends: fail == 4.9.*-- 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+name: free +category: Control, Monads +version: 5.1.10 +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 == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , 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.2 +synopsis: Monads for free +description: + Free monads are useful for many tree-like structures and domain specific languages. + . + 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 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. + . + More information on free monads, including examples, can be found in the + following blog posts: + <http://comonad.com/reader/2008/monads-for-free/> + <http://comonad.com/reader/2011/free-monads-for-less/> + +build-type: Simple +extra-source-files: + .ghci + .gitignore + .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 + include/free-common.h +extra-doc-files: + examples/*.hs + examples/*.lhs + +source-repository head + type: git + location: git://github.com/ekmett/free.git + +library + hs-source-dirs: src + include-dirs: include + includes: free-common.h + + default-language: Haskell2010 + default-extensions: CPP + other-extensions: + MultiParamTypeClasses + FunctionalDependencies + FlexibleInstances + UndecidableInstances + Rank2Types + GADTs + + build-depends: + base >= 4.5 && < 5, + comonad >= 5.0.8 && < 6, + containers >= 0.3 && < 0.7, + distributive >= 0.5.2 && < 1, + exceptions >= 0.10.4 && < 0.11, + indexed-traversable >= 0.1.1 && < 0.2, + semigroupoids >= 5.3.5 && < 6, + th-abstraction >= 0.4.2.0 && < 0.5, + transformers >= 0.3 && < 0.7, + transformers-base >= 0.4.5.2 && < 0.5, + template-haskell >= 2.7.0.0 && < 2.20 + + -- GHC-7.8 bundles transformers-0.3, + -- mtl-2.2.* requires transformers >=0.4 + if impl(ghc >=7.10) + build-depends: + mtl >= 2.2.2 && < 2.4 + else + build-depends: + mtl >= 2.1.3.1 && < 2.4 + + -- recent profunctors dropped support for GHCs older than 7.8 + if impl(ghc >=7.8) + build-depends: + profunctors >= 5.6.1 && < 6 + else + build-depends: + profunctors >= 5.2.2 && < 5.3 + + if !impl(ghc >= 8.2) + build-depends: bifunctors >= 5.5.9 && < 6 + + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.5 && < 1 + + -- Ensure Data.Functor.Classes is always available + if impl(ghc >= 7.10) + build-depends: transformers >= 0.4.2.0 + else + build-depends: transformers-compat >= 0.5.1.0 && <0.8 + + 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.Monad.Trans.Free.Ap + Control.Monad.Trans.Free.Church + Control.Monad.Trans.Iter + + other-modules: + Data.Functor.Classes.Compat + + ghc-options: -Wall + + -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if !impl(ghc >= 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + else + build-depends: fail == 4.9.* + + 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
include/free-common.h view
@@ -1,23 +1,23 @@-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif--#ifndef MIN_VERSION_transformers_compat-#define MIN_VERSION_transformers_compat(x,y,z) 0-#endif--#if MIN_VERSION_base(4,9,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers(0,5,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)-#define LIFTED_FUNCTOR_CLASSES 1-#endif-#endif-#endif+#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +#ifndef MIN_VERSION_transformers_compat +#define MIN_VERSION_transformers_compat(x,y,z) 0 +#endif + +#if MIN_VERSION_base(4,9,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers(0,5,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#endif +#endif +#endif
src/Control/Alternative/Free.hs view
@@ -1,164 +1,164 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Alternative.Free--- Copyright : (C) 2012 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : GADTs, Rank2Types------ Left distributive 'Alternative' functors for free, based on a design--- by Stijn van Drongelen.------------------------------------------------------------------------------module Control.Alternative.Free- ( Alt(..)- , AltF(..)- , runAlt- , liftAlt- , hoistAlt- ) where--import Control.Applicative-import Data.Functor.Apply-import Data.Functor.Alt ((<!>))-import qualified Data.Functor.Alt as Alt-import Data.Typeable--#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup-#endif--infixl 3 `Ap`--data AltF f a where- Ap :: f a -> Alt f (a -> b) -> AltF f b- Pure :: a -> AltF f a-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif--newtype Alt f a = Alt { alternatives :: [AltF f a] }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif--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 (Alt xs) = Alt $ map (fmap f) xs--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 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 as <|> Alt bs = Alt (as ++ bs)- {-# INLINE (<|>) #-}--instance Semigroup (Alt f a) where- (<>) = (<|>)- {-# INLINE (<>) #-}--instance Monoid (Alt f a) where- mempty = empty- {-# INLINE mempty #-}- mappend = (<>)- {-# INLINE mappend #-}- mconcat as = Alt (as >>= alternatives)- {-# INLINE mconcat #-}--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 f (Alt as) = Alt (map (hoistAltF f) as)-{-# INLINE hoistAlt #-}--#if __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--instance Typeable1 f => Typeable1 (AltF f) where- typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where- f :: AltF f a -> f a- f = undefined--altTyCon, altFTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-altTyCon = mkTyCon "Control.Alternative.Free.Alt"-altFTyCon = mkTyCon "Control.Alternative.Free.AltF"-#else-altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt"-altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF"-#endif-{-# NOINLINE altTyCon #-}-{-# NOINLINE altFTyCon #-}-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Alternative.Free +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- Left distributive 'Alternative' functors for free, based on a design +-- by Stijn van Drongelen. +---------------------------------------------------------------------------- +module Control.Alternative.Free + ( Alt(..) + , AltF(..) + , runAlt + , liftAlt + , hoistAlt + ) where + +import Control.Applicative +import Data.Functor.Apply +import Data.Functor.Alt ((<!>)) +import qualified Data.Functor.Alt as Alt +import Data.Typeable + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +infixl 3 `Ap` + +data AltF f a where + Ap :: f a -> Alt f (a -> b) -> AltF f b + Pure :: a -> AltF f a +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +newtype Alt f a = Alt { alternatives :: [AltF f a] } +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +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 (Alt xs) = Alt $ map (fmap f) xs + +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 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 as <|> Alt bs = Alt (as ++ bs) + {-# INLINE (<|>) #-} + +instance Semigroup (Alt f a) where + (<>) = (<|>) + {-# INLINE (<>) #-} + +instance Monoid (Alt f a) where + mempty = empty + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + mconcat as = Alt (as >>= alternatives) + {-# INLINE mconcat #-} + +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 f (Alt as) = Alt (map (hoistAltF f) as) +{-# INLINE hoistAlt #-} + +#if __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 + +instance Typeable1 f => Typeable1 (AltF f) where + typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where + f :: AltF f a -> f a + f = undefined + +altTyCon, altFTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +altTyCon = mkTyCon "Control.Alternative.Free.Alt" +altFTyCon = mkTyCon "Control.Alternative.Free.AltF" +#else +altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt" +altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF" +#endif +{-# NOINLINE altTyCon #-} +{-# NOINLINE altFTyCon #-} +#endif
src/Control/Alternative/Free/Final.hs view
@@ -1,73 +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))-+{-# 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,144 +1,144 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Applicative.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' functors for free------------------------------------------------------------------------------module Control.Applicative.Free- (- -- | 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.Typeable--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif---- | 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)--instance Apply (Ap f) where- Pure f <.> y = fmap f y- Ap x y <.> z = Ap x (flip <$> y <.> z)--instance Applicative (Ap f) where- pure = Pure- 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)- --- | 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)---- | 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--#if __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--apTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apTyCon = mkTyCon "Control.Applicative.Free.Ap"-#else-apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap"-#endif-{-# NOINLINE apTyCon #-}--#endif--{- $examples--<examples/ValidationForm.hs Validation form>---}+{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.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' functors for free +---------------------------------------------------------------------------- +module Control.Applicative.Free + ( + -- | 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.Typeable + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +-- | 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) + +instance Apply (Ap f) where + Pure f <.> y = fmap f y + Ap x y <.> z = Ap x (flip <$> y <.> z) + +instance Applicative (Ap f) where + pure = Pure + 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) + +-- | 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) + +-- | 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 + +#if __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 + +apTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apTyCon = mkTyCon "Control.Applicative.Free.Ap" +#else +apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap" +#endif +{-# NOINLINE apTyCon #-} + +#endif + +{- $examples + +<examples/ValidationForm.hs Validation form> + +-}
src/Control/Applicative/Free/Fast.hs view
@@ -1,169 +1,169 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"------------------------------------------------------------------------------------- |--- 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-import Data.Typeable--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif---- | 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)-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif---- | 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 }-#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 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--#if __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--apTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apTyCon = mkTyCon "Control.Applicative.Free.Fast.Ap"-#else-apTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "Ap"-#endif-{-# NOINLINE apTyCon #-}--instance Typeable1 f => Typeable1 (ASeq f) where- typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where- f :: ASeq f a -> f a- f = undefined--apSeqTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apSeqTyCon = mkTyCon "Control.Applicative.Free.Fast.ASeq"-#else-apSeqTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "ASeq"-#endif-{-# NOINLINE apSeqTyCon #-}--#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +-------------------------------------------------------------------------------- +-- | +-- 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 +import Data.Typeable + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +-- | 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) +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +-- | 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 } +#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 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 + +#if __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 + +apTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apTyCon = mkTyCon "Control.Applicative.Free.Fast.Ap" +#else +apTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "Ap" +#endif +{-# NOINLINE apTyCon #-} + +instance Typeable1 f => Typeable1 (ASeq f) where + typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where + f :: ASeq f a -> f a + f = undefined + +apSeqTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apSeqTyCon = mkTyCon "Control.Applicative.Free.Fast.ASeq" +#else +apSeqTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "ASeq" +#endif +{-# NOINLINE apSeqTyCon #-} + +#endif
src/Control/Applicative/Free/Final.hs view
@@ -1,91 +1,91 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Safe #-}-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif---- | The free 'Applicative' for a 'Functor' @f@.-newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a }---- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.------ prop> runAp t == retractApp . hoistApp t-runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a-runAp phi m = _runAp m phi---- | Perform a monoidal analysis over free applicative value.------ Example:------ @--- count :: Ap f a -> Int--- count = getSum . runAp_ (\\_ -> Sum 1)--- @-runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m-runAp_ f = getConst . runAp (Const . f)--instance Functor (Ap f) where- fmap f (Ap g) = Ap (\k -> fmap f (g k))--instance Apply (Ap f) where- Ap f <.> Ap x = Ap (\k -> f k <*> x k)--instance Applicative (Ap f) where- pure x = Ap (\_ -> pure x)- Ap f <*> Ap x = Ap (\k -> f k <*> x k)---- | A version of 'lift' that can be used with just a 'Functor' for @f@.-liftAp :: f a -> Ap f a-liftAp x = Ap (\k -> k x)---- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.-hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b-hoistAp f (Ap g) = Ap (\k -> g (k . f))---- | Interprets the free applicative functor over f using the semantics for--- `pure` and `<*>` given by the Applicative instance for f.------ prop> retractApp == runAp id-retractAp :: Applicative f => Ap f a -> f a-retractAp (Ap g) = g id--{- $examples--<examples/ValidationForm.hs Validation form>---}+{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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 + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +-- | The free 'Applicative' for a 'Functor' @f@. +newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a } + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp phi m = _runAp m phi + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: Ap f a -> Int +-- count = getSum . runAp_ (\\_ -> Sum 1) +-- @ +runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m +runAp_ f = getConst . runAp (Const . f) + +instance Functor (Ap f) where + fmap f (Ap g) = Ap (\k -> fmap f (g k)) + +instance Apply (Ap f) where + Ap f <.> Ap x = Ap (\k -> f k <*> x k) + +instance Applicative (Ap f) where + pure x = Ap (\_ -> pure x) + Ap f <*> Ap x = Ap (\k -> f k <*> x k) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp x = Ap (\k -> k x) + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b +hoistAp f (Ap g) = Ap (\k -> g (k . f)) + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp (Ap g) = g id + +{- $examples + +<examples/ValidationForm.hs Validation form> + +-}
src/Control/Applicative/Trans/Free.hs view
@@ -1,233 +1,233 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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-import Data.Typeable-#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (Monoid)-#endif-import qualified Data.Foldable as F---- | 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-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif---- | The free 'Applicative' transformer for a 'Functor' @f@ over--- 'Applicative' @g@.-newtype ApT f g a = ApT { getApT :: g (ApF f g a) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif--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, 'F.Foldable' g) => 'ApT' f g a -> 'Int'--- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum'--- @------ @--- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'--- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.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, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a-runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs- where- h (Pure x) = pure x- h (Ap x g) = f x <**> runAlt f g--#if __GLASGOW_HASKELL__ < 707-instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where- typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where- f :: ApT f g a -> g (f a)- f = undefined--instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where- typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where- f :: ApF f g a -> g (f a)- f = undefined--apTTyCon, apFTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT"-apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF"-#else-apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT"-apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF"-#endif-{-# NOINLINE apTTyCon #-}-{-# NOINLINE apFTyCon #-}-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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 +import Data.Typeable +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid) +#endif +import qualified Data.Foldable as F + +-- | 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 +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +-- | The free 'Applicative' transformer for a 'Functor' @f@ over +-- 'Applicative' @g@. +newtype ApT f g a = ApT { getApT :: g (ApF f g a) } +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +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, 'F.Foldable' g) => 'ApT' f g a -> 'Int' +-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum' +-- @ +-- +-- @ +-- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int' +-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.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, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a +runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs + where + h (Pure x) = pure x + h (Ap x g) = f x <**> runAlt f g + +#if __GLASGOW_HASKELL__ < 707 +instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where + typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where + f :: ApT f g a -> g (f a) + f = undefined + +instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where + typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where + f :: ApF f g a -> g (f a) + f = undefined + +apTTyCon, apFTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT" +apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF" +#else +apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT" +apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF" +#endif +{-# NOINLINE apTTyCon #-} +{-# NOINLINE apFTyCon #-} +#endif
src/Control/Comonad/Cofree.hs view
@@ -1,507 +1,507 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Comonad.Cofree--- Copyright : (C) 2008-2013 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : MPTCs, fundeps------ Cofree comonads---------------------------------------------------------------------------------module Control.Comonad.Cofree- ( Cofree(..)- , ComonadCofree(..)- , section- , coiter- , coiterW- , unfold- , unfoldM- , hoistCofree- -- * Lenses into cofree comonads- , _extract- , _unwrap- , telescoped- , telescoped_- , shoots- , leaves- ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Class-import Control.Comonad.Cofree.Class-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.Compat-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 Prelude hiding (id,(.))-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics hiding (Infix, Prefix)-#endif---infixr 5 :<---- | The 'Cofree' 'Comonad' of a functor @f@.------ /Formally/------ A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every comonad homomorphism--- 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.------ Cofree is a functor from the category of functors to the category of comonads--- that is right adjoint to the forgetful functor from the category of comonads--- to the category of functors that forgets how to 'extract' and--- 'duplicate', leaving you with only a 'Functor'.------ In practice, cofree comonads are quite useful for annotating syntax trees,--- or talking about streams.------ A number of common comonads arise directly as cofree comonads.------ For instance,------ * @'Cofree' 'Maybe'@ forms the comonad for a non-empty list.------ * @'Cofree' ('Const' b)@ is a product.------ * @'Cofree' 'Identity'@ forms an infinite stream.------ * @'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, Generic, Generic1)--deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a)-#endif---- | 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 #-}--instance Distributive f => Distributive (Cofree f) where- distribute w = fmap extract w :< fmap distribute (collect unwrap w)--instance Functor f => Functor (Cofree f) where- fmap f (a :< as) = f a :< fmap (fmap f) as- b <$ (_ :< as) = b :< fmap (b <$) as--instance Functor f => Extend (Cofree f) where- extended = extend- {-# INLINE extended #-}- duplicated = duplicate- {-# INLINE duplicated #-}--instance Functor f => Comonad (Cofree f) where- extend f w = f w :< fmap (extend f) (unwrap w)- duplicate w = w :< fmap duplicate (unwrap w)- extract (a :< _) = a- {-# INLINE extract #-}---- | This is not a true 'Comonad' transformer, but this instance is convenient.-instance ComonadTrans Cofree where- lower (_ :< as) = fmap extract as- {-# INLINE lower #-}--instance Alternative f => Monad (Cofree f) where- 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'@-section :: Comonad f => f a -> Cofree f a-section as = extract as :< extend section as--instance Apply f => Apply (Cofree f) where- (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as)- {-# INLINE (<.>) #-}- (f :< fs) <. (_ :< as) = f :< ((<. ) <$> fs <.> as)- {-# INLINE (<.) #-}- (_ :< fs) .> (a :< as) = a :< (( .>) <$> fs <.> as)- {-# INLINE (.>) #-}--instance ComonadApply f => ComonadApply (Cofree f) where- (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as)- {-# INLINE (<@>) #-}- (f :< fs) <@ (_ :< as) = f :< ((<@ ) <$> fs <@> as)- {-# INLINE (<@) #-}- (_ :< fs) @> (a :< as) = a :< (( @>) <$> fs <@> as)- {-# INLINE (@>) #-}--instance Alternative f => Applicative (Cofree f) where- pure x = x :< empty- {-# INLINE pure #-}- (<*>) = ap- {-# INLINE (<*>) #-}--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Show1 f) => Show1 (Cofree f) where- showsPrec1 d (a :< as) = showParen (d > 5) $- showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 f, Show a) => Show (Cofree f a) where-#else-instance (Functor f, Show1 f, Show a) => Show (Cofree f a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Read1 f) => Read1 (Cofree f) where- readsPrec1 d r = readParen (d > 5)- (\r' -> [(u :< fmap lower1 v,w) |- (u, s) <- readsPrec 6 r',- (":<", t) <- lex s,- (v, w) <- readsPrec1 5 t]) r-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 f, Read a) => Read (Cofree f a) where-#else-instance (Functor f, Read1 f, Read a) => Read (Cofree f a) where-#endif- readsPrec = readsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f, Eq a) => Eq (Cofree f a) where-#else-instance (Functor f, Eq1 f, Eq a) => Eq (Cofree f a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f) => Eq1 (Cofree f) where- liftEq eq = go- where- go (a :< as) (b :< bs) = eq a b && liftEq go as bs-#else-instance (Functor f, Eq1 f) => Eq1 (Cofree f) where-#ifndef HLINT- eq1 (a :< as) (b :< bs) = a == b && eq1 (fmap Lift1 as) (fmap Lift1 bs)-#endif-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f, Ord a) => Ord (Cofree f a) where-#else-instance (Functor f, Ord1 f, Ord a) => Ord (Cofree f a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f) => Ord1 (Cofree f) where- liftCompare cmp = go- where- go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs-#else-instance (Functor f, Ord1 f) => Ord1 (Cofree f) where- compare1 (a :< as) (b :< bs) = case compare a b of- LT -> LT- EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs)- GT -> GT-#endif--instance Foldable f => Foldable (Cofree f) where- foldMap f = go where- go (a :< as) = f a `mappend` foldMap go as- {-# INLINE foldMap #-}-#if __GLASGOW_HASKELL__ >= 709- length = go 0 where- go s (_ :< as) = foldl' go (s + 1) as-#endif--instance Foldable1 f => Foldable1 (Cofree f) where- foldMap1 f = go where- go (a :< as) = f a <> foldMap1 go as- {-# INLINE foldMap1 #-}--instance Traversable f => Traversable (Cofree f) where- traverse f = go where- go (a :< as) = (:<) <$> f a <*> traverse go as- {-# INLINE traverse #-}--instance Traversable1 f => Traversable1 (Cofree f) where- traverse1 f = go where- go (a :< as) = (:<) <$> f a <.> traverse1 go as- {-# INLINE traverse1 #-}--instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where- imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as- {-# INLINE imap #-}--instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where- ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as- {-# INLINE ifoldMap #-}--instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where- itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as- {-# INLINE itraverse #-}--#if __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- ( 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--cofreeConstr :: Constr-cofreeConstr = mkConstr cofreeDataType ":<" [] Infix-{-# NOINLINE cofreeConstr #-}--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- {-# INLINE ask #-}--instance ComonadStore s w => ComonadStore s (Cofree w) where- pos (_ :< as) = Class.pos as- {-# INLINE pos #-}- peek s (_ :< as) = extract (Class.peek s as)- {-# INLINE peek #-}--instance ComonadTraced m w => ComonadTraced m (Cofree w) where- trace m = trace m . lower- {-# INLINE trace #-}---- | This is a lens that can be used to read or write from the target of 'extract'.------ Using (^.) from the @lens@ package:------ @foo ^. '_extract' == 'extract' foo@------ For more on lenses see the @lens@ package on hackage------ @'_extract' :: Lens' ('Cofree' g a) a@-_extract :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)-_extract f (a :< as) = (:< as) <$> f a-{-# INLINE _extract #-}---- | This is a lens that can be used to read or write to the tails of a 'Cofree' 'Comonad'.------ Using (^.) from the @lens@ package:------ @foo ^. '_unwrap' == 'unwrap' foo@------ For more on lenses see the @lens@ package on hackage------ @'_unwrap' :: Lens' ('Cofree' g a) (g ('Cofree' g a))@-_unwrap :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)-_unwrap f (a :< as) = (a :<) <$> f as-{-# INLINE _unwrap #-}---- | 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 :: [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-#if __GLASGOW_HASKELL__ < 709- go xxs@(x :< xs) | null (toList xs) = pure xxs-#else- go xxs@(x :< xs) | null xs = pure xxs-#endif- | 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-#if __GLASGOW_HASKELL__ < 709- go (x :< xs) | null (toList xs) = (:< xs) <$> f x-#else- go (x :< xs) | null xs = (:< xs) <$> f x-#endif- | otherwise = (x :<) <$> traverse go xs-{-# INLINE leaves #-}+{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Cofree +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Cofree comonads +-- +---------------------------------------------------------------------------- +module Control.Comonad.Cofree + ( Cofree(..) + , ComonadCofree(..) + , section + , coiter + , coiterW + , unfold + , unfoldM + , hoistCofree + -- * Lenses into cofree comonads + , _extract + , _unwrap + , telescoped + , telescoped_ + , shoots + , leaves + ) where + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Trans.Class +import Control.Comonad.Cofree.Class +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.Compat +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 Prelude hiding (id,(.)) +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics hiding (Infix, Prefix) +#endif + + +infixr 5 :< + +-- | The 'Cofree' 'Comonad' of a functor @f@. +-- +-- /Formally/ +-- +-- A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every comonad homomorphism +-- 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. +-- +-- Cofree is a functor from the category of functors to the category of comonads +-- that is right adjoint to the forgetful functor from the category of comonads +-- to the category of functors that forgets how to 'extract' and +-- 'duplicate', leaving you with only a 'Functor'. +-- +-- In practice, cofree comonads are quite useful for annotating syntax trees, +-- or talking about streams. +-- +-- A number of common comonads arise directly as cofree comonads. +-- +-- For instance, +-- +-- * @'Cofree' 'Maybe'@ forms the comonad for a non-empty list. +-- +-- * @'Cofree' ('Const' b)@ is a product. +-- +-- * @'Cofree' 'Identity'@ forms an infinite stream. +-- +-- * @'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, Generic, Generic1) + +deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a) +#endif + +-- | 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 #-} + +instance Distributive f => Distributive (Cofree f) where + distribute w = fmap extract w :< fmap distribute (collect unwrap w) + +instance Functor f => Functor (Cofree f) where + fmap f (a :< as) = f a :< fmap (fmap f) as + b <$ (_ :< as) = b :< fmap (b <$) as + +instance Functor f => Extend (Cofree f) where + extended = extend + {-# INLINE extended #-} + duplicated = duplicate + {-# INLINE duplicated #-} + +instance Functor f => Comonad (Cofree f) where + extend f w = f w :< fmap (extend f) (unwrap w) + duplicate w = w :< fmap duplicate (unwrap w) + extract (a :< _) = a + {-# INLINE extract #-} + +-- | This is not a true 'Comonad' transformer, but this instance is convenient. +instance ComonadTrans Cofree where + lower (_ :< as) = fmap extract as + {-# INLINE lower #-} + +instance Alternative f => Monad (Cofree f) where + 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'@ +section :: Comonad f => f a -> Cofree f a +section as = extract as :< extend section as + +instance Apply f => Apply (Cofree f) where + (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as) + {-# INLINE (<.>) #-} + (f :< fs) <. (_ :< as) = f :< ((<. ) <$> fs <.> as) + {-# INLINE (<.) #-} + (_ :< fs) .> (a :< as) = a :< (( .>) <$> fs <.> as) + {-# INLINE (.>) #-} + +instance ComonadApply f => ComonadApply (Cofree f) where + (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as) + {-# INLINE (<@>) #-} + (f :< fs) <@ (_ :< as) = f :< ((<@ ) <$> fs <@> as) + {-# INLINE (<@) #-} + (_ :< fs) @> (a :< as) = a :< (( @>) <$> fs <@> as) + {-# INLINE (@>) #-} + +instance Alternative f => Applicative (Cofree f) where + pure x = x :< empty + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Show1 f) => Show1 (Cofree f) where + showsPrec1 d (a :< as) = showParen (d > 5) $ + showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 f, Show a) => Show (Cofree f a) where +#else +instance (Functor f, Show1 f, Show a) => Show (Cofree f a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Read1 f) => Read1 (Cofree f) where + readsPrec1 d r = readParen (d > 5) + (\r' -> [(u :< fmap lower1 v,w) | + (u, s) <- readsPrec 6 r', + (":<", t) <- lex s, + (v, w) <- readsPrec1 5 t]) r +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 f, Read a) => Read (Cofree f a) where +#else +instance (Functor f, Read1 f, Read a) => Read (Cofree f a) where +#endif + readsPrec = readsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq a) => Eq (Cofree f a) where +#else +instance (Functor f, Eq1 f, Eq a) => Eq (Cofree f a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f) => Eq1 (Cofree f) where + liftEq eq = go + where + go (a :< as) (b :< bs) = eq a b && liftEq go as bs +#else +instance (Functor f, Eq1 f) => Eq1 (Cofree f) where +#ifndef HLINT + eq1 (a :< as) (b :< bs) = a == b && eq1 (fmap Lift1 as) (fmap Lift1 bs) +#endif +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord a) => Ord (Cofree f a) where +#else +instance (Functor f, Ord1 f, Ord a) => Ord (Cofree f a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f) => Ord1 (Cofree f) where + liftCompare cmp = go + where + go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs +#else +instance (Functor f, Ord1 f) => Ord1 (Cofree f) where + compare1 (a :< as) (b :< bs) = case compare a b of + LT -> LT + EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs) + GT -> GT +#endif + +instance Foldable f => Foldable (Cofree f) where + foldMap f = go where + go (a :< as) = f a `mappend` foldMap go as + {-# INLINE foldMap #-} +#if __GLASGOW_HASKELL__ >= 709 + length = go 0 where + go s (_ :< as) = foldl' go (s + 1) as +#endif + +instance Foldable1 f => Foldable1 (Cofree f) where + foldMap1 f = go where + go (a :< as) = f a <> foldMap1 go as + {-# INLINE foldMap1 #-} + +instance Traversable f => Traversable (Cofree f) where + traverse f = go where + go (a :< as) = (:<) <$> f a <*> traverse go as + {-# INLINE traverse #-} + +instance Traversable1 f => Traversable1 (Cofree f) where + traverse1 f = go where + go (a :< as) = (:<) <$> f a <.> traverse1 go as + {-# INLINE traverse1 #-} + +instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where + imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where + ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where + itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as + {-# INLINE itraverse #-} + +#if __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 + ( 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 + +cofreeConstr :: Constr +cofreeConstr = mkConstr cofreeDataType ":<" [] Infix +{-# NOINLINE cofreeConstr #-} + +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 + {-# INLINE ask #-} + +instance ComonadStore s w => ComonadStore s (Cofree w) where + pos (_ :< as) = Class.pos as + {-# INLINE pos #-} + peek s (_ :< as) = extract (Class.peek s as) + {-# INLINE peek #-} + +instance ComonadTraced m w => ComonadTraced m (Cofree w) where + trace m = trace m . lower + {-# INLINE trace #-} + +-- | This is a lens that can be used to read or write from the target of 'extract'. +-- +-- Using (^.) from the @lens@ package: +-- +-- @foo ^. '_extract' == 'extract' foo@ +-- +-- For more on lenses see the @lens@ package on hackage +-- +-- @'_extract' :: Lens' ('Cofree' g a) a@ +_extract :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a) +_extract f (a :< as) = (:< as) <$> f a +{-# INLINE _extract #-} + +-- | This is a lens that can be used to read or write to the tails of a 'Cofree' 'Comonad'. +-- +-- Using (^.) from the @lens@ package: +-- +-- @foo ^. '_unwrap' == 'unwrap' foo@ +-- +-- For more on lenses see the @lens@ package on hackage +-- +-- @'_unwrap' :: Lens' ('Cofree' g a) (g ('Cofree' g a))@ +_unwrap :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a) +_unwrap f (a :< as) = (a :<) <$> f as +{-# INLINE _unwrap #-} + +-- | 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 :: [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 +#if __GLASGOW_HASKELL__ < 709 + go xxs@(x :< xs) | null (toList xs) = pure xxs +#else + go xxs@(x :< xs) | null xs = pure xxs +#endif + | 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 +#if __GLASGOW_HASKELL__ < 709 + go (x :< xs) | null (toList xs) = (:< xs) <$> f x +#else + go (x :< xs) | null xs = (:< xs) <$> f x +#endif + | otherwise = (x :<) <$> traverse go xs +{-# INLINE leaves #-}
src/Control/Comonad/Cofree/Class.hs view
@@ -1,60 +1,60 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE UndecidableInstances #-}-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Comonad.Cofree.Class--- Copyright : (C) 2008-2011 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : fundeps, MPTCs------------------------------------------------------------------------------module Control.Comonad.Cofree.Class- ( ComonadCofree(..)- ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Env-import Control.Comonad.Trans.Store-import Control.Comonad.Trans.Traced-import Control.Comonad.Trans.Identity-import Data.List.NonEmpty (NonEmpty(..))-import Data.Tree-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif---- | 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--instance ComonadCofree f w => ComonadCofree f (EnvT e w) where- unwrap (EnvT e wa) = EnvT e <$> unwrap wa--instance ComonadCofree f w => ComonadCofree f (StoreT s w) where- unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa--instance (ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where- unwrap (TracedT wma) = TracedT <$> unwrap wma+{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE UndecidableInstances #-} +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Cofree.Class +-- Copyright : (C) 2008-2011 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability : fundeps, MPTCs +---------------------------------------------------------------------------- +module Control.Comonad.Cofree.Class + ( ComonadCofree(..) + ) where + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Trans.Env +import Control.Comonad.Trans.Store +import Control.Comonad.Trans.Traced +import Control.Comonad.Trans.Identity +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Tree +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif + +-- | 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 + +instance ComonadCofree f w => ComonadCofree f (EnvT e w) where + unwrap (EnvT e wa) = EnvT e <$> unwrap wa + +instance ComonadCofree f w => ComonadCofree f (StoreT s w) where + unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa + +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,352 +1,352 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Comonad.Trans.Cofree--- 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 cofree comonad transformer------------------------------------------------------------------------------module Control.Comonad.Trans.Cofree- ( CofreeT(..)- , Cofree, cofree, runCofree- , CofreeF(..)- , ComonadCofree(..)- , headF- , tailF- , transCofreeT- , coiterT- ) where--import Control.Applicative-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.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,(.))-import Data.Data-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics hiding (Infix, Prefix)-#endif--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid-#endif--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, Generic, Generic1-#endif- )--#ifdef LIFTED_FUNCTOR_CLASSES-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--#else-instance (Functor f, Show1 f, Show a) => Show1 (CofreeF f a) where- showsPrec1 d (a :< fb) = showParen (d > 5) $- showsPrec 6 a . showString " :< " . showsPrec1 6 fb-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Read1 f, Read a) => Read1 (CofreeF f a) where- readsPrec1 d =- readParen (d > 5) $- (\r' -> [ (u :< v,w)- | (u, s) <- readsPrec 6 r'- , (":<", t) <- lex s- , (v, w) <- readsPrec1 6 t- ])-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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 (==)-#else-instance (Eq1 f, Eq a) => Eq1 (CofreeF f a) where- eq1 (a :< fb) (a' :< fb') = a == a' && eq1 fb fb'-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Ord1 f, Ord a) => Ord1 (CofreeF f a) where- compare1 (a :< fb) (a' :< fb') =- case compare a a' of- LT -> LT- EQ -> compare1 fb fb'- GT -> GT-#endif---- | Extract the head of the base functor-headF :: CofreeF f a b -> a-headF (a :< _) = a---- | Extract the tails of the base functor-tailF :: CofreeF f a b -> f b-tailF (_ :< as) = as--instance Functor f => Functor (CofreeF f a) where- fmap f (a :< as) = a :< fmap f as--instance Foldable f => Foldable (CofreeF f a) where- foldMap f (_ :< as) = foldMap f as--instance Traversable f => Traversable (CofreeF f a) where- traverse f (a :< as) = (a :<) <$> traverse f as--instance Functor f => Bifunctor (CofreeF f) where- bimap f g (a :< as) = f a :< fmap g as--instance Foldable f => Bifoldable (CofreeF f) where- bifoldMap f g (a :< as) = f a `mappend` foldMap g as--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)) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif---- | 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--instance (Functor f, Comonad w) => Comonad (CofreeT f w) where- extract = headF . extract . runCofreeT- extend f = CofreeT . extend (\w -> f (CofreeT w) :< (extend f <$> tailF (extract w))) . runCofreeT--instance (Foldable f, Foldable w) => Foldable (CofreeT f w) where- foldMap f = foldMap (bifoldMap f (foldMap f)) . runCofreeT--instance (Traversable f, Traversable w) => Traversable (CofreeT f w) where- traverse f = fmap CofreeT . traverse (bitraverse f (traverse f)) . runCofreeT--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 (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- readsPrec d = readParen (d > 10) $ \r ->- [(CofreeT w, t) | ("CofreeT", s) <- lex r, (w, t) <- readsPrec 11 s]--instance Eq (w (CofreeF f a (CofreeT f w a))) => Eq (CofreeT f w a) where- CofreeT a == CofreeT b = a == b--instance Ord (w (CofreeF f a (CofreeT f w a))) => Ord (CofreeT f w a) where- compare (CofreeT a) (CofreeT b) = compare a b--instance (Alternative f, Monad w) => Monad (CofreeT f w) where-#if __GLASGOW_HASKELL__ < 710- return = CofreeT . return . (:< empty)- {-# INLINE return #-}-#endif- CofreeT cx >>= f = CofreeT $ do- a :< m <- cx- b :< n <- runCofreeT $ f a- return $ b :< (n <|> fmap (>>= f) m)---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 Alternative f => MonadTrans (CofreeT f) where- lift = CofreeT . liftM (:< empty)--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)---- | 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))--#if __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 (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--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 #-}--#else-#define Typeable1 Typeable-#endif--instance- ( Typeable1 f, Typeable a, Typeable b- , 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--instance- ( Typeable1 f, Typeable1 w, Typeable a- , 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 #-}---- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a--- lowerF = fmap extract . unwrap+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Trans.Cofree +-- 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 cofree comonad transformer +---------------------------------------------------------------------------- +module Control.Comonad.Trans.Cofree + ( CofreeT(..) + , Cofree, cofree, runCofree + , CofreeF(..) + , ComonadCofree(..) + , headF + , tailF + , transCofreeT + , coiterT + ) where + +import Control.Applicative +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.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,(.)) +import Data.Data +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics hiding (Infix, Prefix) +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +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, Generic, Generic1 +#endif + ) + +#ifdef LIFTED_FUNCTOR_CLASSES +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 + +#else +instance (Functor f, Show1 f, Show a) => Show1 (CofreeF f a) where + showsPrec1 d (a :< fb) = showParen (d > 5) $ + showsPrec 6 a . showString " :< " . showsPrec1 6 fb +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Read1 f, Read a) => Read1 (CofreeF f a) where + readsPrec1 d = + readParen (d > 5) $ + (\r' -> [ (u :< v,w) + | (u, s) <- readsPrec 6 r' + , (":<", t) <- lex s + , (v, w) <- readsPrec1 6 t + ]) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 (==) +#else +instance (Eq1 f, Eq a) => Eq1 (CofreeF f a) where + eq1 (a :< fb) (a' :< fb') = a == a' && eq1 fb fb' +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Ord1 f, Ord a) => Ord1 (CofreeF f a) where + compare1 (a :< fb) (a' :< fb') = + case compare a a' of + LT -> LT + EQ -> compare1 fb fb' + GT -> GT +#endif + +-- | Extract the head of the base functor +headF :: CofreeF f a b -> a +headF (a :< _) = a + +-- | Extract the tails of the base functor +tailF :: CofreeF f a b -> f b +tailF (_ :< as) = as + +instance Functor f => Functor (CofreeF f a) where + fmap f (a :< as) = a :< fmap f as + +instance Foldable f => Foldable (CofreeF f a) where + foldMap f (_ :< as) = foldMap f as + +instance Traversable f => Traversable (CofreeF f a) where + traverse f (a :< as) = (a :<) <$> traverse f as + +instance Functor f => Bifunctor (CofreeF f) where + bimap f g (a :< as) = f a :< fmap g as + +instance Foldable f => Bifoldable (CofreeF f) where + bifoldMap f g (a :< as) = f a `mappend` foldMap g as + +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)) } +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +-- | 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 + +instance (Functor f, Comonad w) => Comonad (CofreeT f w) where + extract = headF . extract . runCofreeT + extend f = CofreeT . extend (\w -> f (CofreeT w) :< (extend f <$> tailF (extract w))) . runCofreeT + +instance (Foldable f, Foldable w) => Foldable (CofreeT f w) where + foldMap f = foldMap (bifoldMap f (foldMap f)) . runCofreeT + +instance (Traversable f, Traversable w) => Traversable (CofreeT f w) where + traverse f = fmap CofreeT . traverse (bitraverse f (traverse f)) . runCofreeT + +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 (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 + readsPrec d = readParen (d > 10) $ \r -> + [(CofreeT w, t) | ("CofreeT", s) <- lex r, (w, t) <- readsPrec 11 s] + +instance Eq (w (CofreeF f a (CofreeT f w a))) => Eq (CofreeT f w a) where + CofreeT a == CofreeT b = a == b + +instance Ord (w (CofreeF f a (CofreeT f w a))) => Ord (CofreeT f w a) where + compare (CofreeT a) (CofreeT b) = compare a b + +instance (Alternative f, Monad w) => Monad (CofreeT f w) where +#if __GLASGOW_HASKELL__ < 710 + return = CofreeT . return . (:< empty) + {-# INLINE return #-} +#endif + CofreeT cx >>= f = CofreeT $ do + a :< m <- cx + b :< n <- runCofreeT $ f a + return $ b :< (n <|> fmap (>>= f) m) + + +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 Alternative f => MonadTrans (CofreeT f) where + lift = CofreeT . liftM (:< empty) + +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) + +-- | 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)) + +#if __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 (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 + +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 #-} + +#else +#define Typeable1 Typeable +#endif + +instance + ( Typeable1 f, Typeable a, Typeable b + , 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 + +instance + ( Typeable1 f, Typeable1 w, Typeable a + , 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 #-} + +-- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a +-- lowerF = fmap extract . unwrap
src/Control/Comonad/Trans/Coiter.hs view
@@ -1,265 +1,265 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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.Compat-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) }-#if __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 w) => Eq1 (CoiterT w) where- liftEq eq = go- where- go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y-#else-instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where- eq1 = on eq1 (fmap (fmap Lift1) . runCoiterT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 w) => Ord1 (CoiterT w) where- liftCompare cmp = go- where- go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y-#else-instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where- compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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 -#else-instance (Functor w, Show1 w) => Show1 (CoiterT w) where- showsPrec1 d (CoiterT as) = showParen (d > 10) $- showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor w, Read1 w) => Read1 (CoiterT w) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s]-#endif---- | 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 #-}--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 w, Show a) => Show (CoiterT w a) where-#else-instance (Functor w, Show1 w, Show a) => Show (CoiterT w a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 w, Read a) => Read (CoiterT w a) where-#else-instance (Functor w, Read1 w, Read a) => Read (CoiterT w a) where-#endif- readsPrec = readsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 w, Eq a) => Eq (CoiterT w a) where-#else-instance (Functor w, Eq1 w, Eq a) => Eq (CoiterT w a) where-#endif- (==) = eq1- {-# INLINE (==) #-}--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 w, Ord a) => Ord (CoiterT w a) where-#else-instance (Functor w, Ord1 w, Ord a) => Ord (CoiterT w a) where-#endif- 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)--#if __GLASGOW_HASKELL__ < 707--instance Typeable1 w => Typeable1 (CoiterT w) where- typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where- w :: CoiterT w a -> w a- w = undefined--coiterTTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT"-#else-coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT"-#endif-{-# NOINLINE coiterTTyCon #-}--#else-#define Typeable1 Typeable-#endif--instance- ( Typeable1 w, Typeable a- , Data (w (a, CoiterT w a))- , Data a- ) => Data (CoiterT w a) where- gfoldl f z (CoiterT w) = z CoiterT `f` w- toConstr _ = coiterTConstr- gunfold k z c = case constrIndex c of- 1 -> k (z CoiterT)- _ -> error "gunfold"- dataTypeOf _ = coiterTDataType- dataCast1 f = gcast1 f--coiterTConstr :: Constr-coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix-{-# NOINLINE coiterTConstr #-}--coiterTDataType :: DataType-coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr]-{-# NOINLINE coiterTDataType #-}--{- $example--<examples/NewtonCoiter.lhs Newton's method>---}+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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.Compat +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) } +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 w) => Eq1 (CoiterT w) where + liftEq eq = go + where + go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y +#else +instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where + eq1 = on eq1 (fmap (fmap Lift1) . runCoiterT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 w) => Ord1 (CoiterT w) where + liftCompare cmp = go + where + go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y +#else +instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where + compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor w, Show1 w) => Show1 (CoiterT w) where + showsPrec1 d (CoiterT as) = showParen (d > 10) $ + showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor w, Read1 w) => Read1 (CoiterT w) where + readsPrec1 d = readParen (d > 10) $ \r -> + [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s] +#endif + +-- | 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 #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 w, Show a) => Show (CoiterT w a) where +#else +instance (Functor w, Show1 w, Show a) => Show (CoiterT w a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 w, Read a) => Read (CoiterT w a) where +#else +instance (Functor w, Read1 w, Read a) => Read (CoiterT w a) where +#endif + readsPrec = readsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 w, Eq a) => Eq (CoiterT w a) where +#else +instance (Functor w, Eq1 w, Eq a) => Eq (CoiterT w a) where +#endif + (==) = eq1 + {-# INLINE (==) #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 w, Ord a) => Ord (CoiterT w a) where +#else +instance (Functor w, Ord1 w, Ord a) => Ord (CoiterT w a) where +#endif + 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) + +#if __GLASGOW_HASKELL__ < 707 + +instance Typeable1 w => Typeable1 (CoiterT w) where + typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where + w :: CoiterT w a -> w a + w = undefined + +coiterTTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT" +#else +coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT" +#endif +{-# NOINLINE coiterTTyCon #-} + +#else +#define Typeable1 Typeable +#endif + +instance + ( Typeable1 w, Typeable a + , Data (w (a, CoiterT w a)) + , Data a + ) => Data (CoiterT w a) where + gfoldl f z (CoiterT w) = z CoiterT `f` w + toConstr _ = coiterTConstr + gunfold k z c = case constrIndex c of + 1 -> k (z CoiterT) + _ -> error "gunfold" + dataTypeOf _ = coiterTDataType + dataCast1 f = gcast1 f + +coiterTConstr :: Constr +coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix +{-# NOINLINE coiterTConstr #-} + +coiterTDataType :: DataType +coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr] +{-# NOINLINE coiterTDataType #-} + +{- $example + +<examples/NewtonCoiter.lhs Newton's method> + +-}
src/Control/Monad/Free.hs view
@@ -1,503 +1,503 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Monad.Free--- Copyright : (C) 2008-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : MPTCs, fundeps------ Monads for free------------------------------------------------------------------------------module Control.Monad.Free- ( 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 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.Compat-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-import Data.Data-import Prelude hiding (foldr)-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics-#endif---- $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/------ 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@.------ /Why Free?/------ Every \"free\" functor is left adjoint to some \"forgetful\" functor.------ If we define a forgetful functor @U@ from the category of monads to the category of functors--- that just forgets the 'Monad', leaving only the 'Functor'. i.e.------ @U (M,'return','Control.Monad.join') = M@------ then 'Free' is the left adjoint to @U@.------ '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.------ Morphisms in the category of monads are 'Monad' homomorphisms (natural transformations that respect 'return' and 'Control.Monad.join').------ Morphisms in the category of functors are 'Functor' homomorphisms (natural transformations).------ Given this isomorphism, every monad homomorphism from @'Free' f@ to @m@ is equivalent to a natural transformation from @f@ to @m@------ Showing that this isomorphism holds is left as an exercise.------ In practice, you can just view a @'Free' f a@ as many layers of @f@ wrapped around values of type @a@, where--- @('>>=')@ performs substitution and grafts new layers of @f@ in for each of the free variables.------ 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 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,------ * Given @data Empty a@, @'Free' Empty@ is isomorphic to the 'Data.Functor.Identity' monad.------ * @'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, Generic, Generic1)--deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Eq1 f) => Eq1 (Free f) where- Pure a `eq1` Pure b = a == b- Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb- _ `eq1` _ = False-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f, Eq a) => Eq (Free f a) where-#else-instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Ord1 f) => Ord1 (Free f) where- Pure a `compare1` Pure b = a `compare` b- Pure _ `compare1` Free _ = LT- Free _ `compare1` Pure _ = GT- Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f, Ord a) => Ord (Free f a) where-#else-instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Show1 f) => Show1 (Free f) where- showsPrec1 d (Pure a) = showParen (d > 10) $- showString "Pure " . showsPrec 11 a- showsPrec1 d (Free m) = showParen (d > 10) $- showString "Free " . showsPrec1 11 (fmap Lift1 m)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 f, Show a) => Show (Free f a) where-#else-instance (Show1 f, Functor f, Show a) => Show (Free f a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Read1 f) => Read1 (Free f) where- readsPrec1 d r = readParen (d > 10)- (\r' -> [ (Pure m, t)- | ("Pure", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r- ++ readParen (d > 10)- (\r' -> [ (Free (fmap lower1 m), t)- | ("Free", s) <- lex r'- , (m, t) <- readsPrec1 11 s]) r-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 f, Read a) => Read (Free f a) where-#else-instance (Read1 f, Functor f, Read a) => Read (Free f a) where-#endif- 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 Functor f => Apply (Free f) where- Pure a <.> Pure b = Pure (a b)- Pure a <.> Free fb = Free $ fmap a <$> fb- Free fa <.> b = Free $ (<.> b) <$> fa--instance Functor 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 <*> b = Free $ (<*> b) <$> ma--instance Functor f => Bind (Free f) where- Pure a >>- f = f a- Free m >>- f = Free ((>>- f) <$> m)--instance Functor f => Monad (Free f) where- 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- {-# INLINE empty #-}- a <|> b = Free (pure a <|> pure b)- {-# INLINE (<|>) #-}---- | This violates the MonadPlus laws, handle with care.-instance (Functor v, 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 #-}--#if MIN_VERSION_base(4,6,0)- foldl' f = go where- go r free =- case free of- Pure a -> f r a- Free fa -> foldl' go r fa- {-# INLINE foldl' #-}-#endif--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 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 (Functor 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, 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, 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- 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 :: Monad f => Free f a -> f a-retract (Pure a) = return a-retract (Free as) = as >>= retract---- | Tear down a 'Free' 'Monad' using iteration.-iter :: Functor 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, 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 (iterM phi <$> f)---- | 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, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)-unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))---- | This is @Prism' (Free f a) a@ in disguise------ >>> preview _Pure (Pure 3)--- 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) (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 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 (Pure x) = Left (Pure x)- {-# INLINE unfree #-}-{-# INLINE _Free #-}---#if __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+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free +-- Copyright : (C) 2008-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Monads for free +---------------------------------------------------------------------------- +module Control.Monad.Free + ( 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 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.Compat +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 +import Data.Data +import Prelude hiding (foldr) +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics +#endif + +-- $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/ +-- +-- 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@. +-- +-- /Why Free?/ +-- +-- Every \"free\" functor is left adjoint to some \"forgetful\" functor. +-- +-- If we define a forgetful functor @U@ from the category of monads to the category of functors +-- that just forgets the 'Monad', leaving only the 'Functor'. i.e. +-- +-- @U (M,'return','Control.Monad.join') = M@ +-- +-- then 'Free' is the left adjoint to @U@. +-- +-- '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. +-- +-- Morphisms in the category of monads are 'Monad' homomorphisms (natural transformations that respect 'return' and 'Control.Monad.join'). +-- +-- Morphisms in the category of functors are 'Functor' homomorphisms (natural transformations). +-- +-- Given this isomorphism, every monad homomorphism from @'Free' f@ to @m@ is equivalent to a natural transformation from @f@ to @m@ +-- +-- Showing that this isomorphism holds is left as an exercise. +-- +-- In practice, you can just view a @'Free' f a@ as many layers of @f@ wrapped around values of type @a@, where +-- @('>>=')@ performs substitution and grafts new layers of @f@ in for each of the free variables. +-- +-- 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 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, +-- +-- * Given @data Empty a@, @'Free' Empty@ is isomorphic to the 'Data.Functor.Identity' monad. +-- +-- * @'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, Generic, Generic1) + +deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Eq1 f) => Eq1 (Free f) where + Pure a `eq1` Pure b = a == b + Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb + _ `eq1` _ = False +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq a) => Eq (Free f a) where +#else +instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Ord1 f) => Ord1 (Free f) where + Pure a `compare1` Pure b = a `compare` b + Pure _ `compare1` Free _ = LT + Free _ `compare1` Pure _ = GT + Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord a) => Ord (Free f a) where +#else +instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Show1 f) => Show1 (Free f) where + showsPrec1 d (Pure a) = showParen (d > 10) $ + showString "Pure " . showsPrec 11 a + showsPrec1 d (Free m) = showParen (d > 10) $ + showString "Free " . showsPrec1 11 (fmap Lift1 m) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 f, Show a) => Show (Free f a) where +#else +instance (Show1 f, Functor f, Show a) => Show (Free f a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Read1 f) => Read1 (Free f) where + readsPrec1 d r = readParen (d > 10) + (\r' -> [ (Pure m, t) + | ("Pure", s) <- lex r' + , (m, t) <- readsPrec 11 s]) r + ++ readParen (d > 10) + (\r' -> [ (Free (fmap lower1 m), t) + | ("Free", s) <- lex r' + , (m, t) <- readsPrec1 11 s]) r +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 f, Read a) => Read (Free f a) where +#else +instance (Read1 f, Functor f, Read a) => Read (Free f a) where +#endif + 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 Functor f => Apply (Free f) where + Pure a <.> Pure b = Pure (a b) + Pure a <.> Free fb = Free $ fmap a <$> fb + Free fa <.> b = Free $ (<.> b) <$> fa + +instance Functor 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 <*> b = Free $ (<*> b) <$> ma + +instance Functor f => Bind (Free f) where + Pure a >>- f = f a + Free m >>- f = Free ((>>- f) <$> m) + +instance Functor f => Monad (Free f) where + 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 + {-# INLINE empty #-} + a <|> b = Free (pure a <|> pure b) + {-# INLINE (<|>) #-} + +-- | This violates the MonadPlus laws, handle with care. +instance (Functor v, 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 #-} + +#if MIN_VERSION_base(4,6,0) + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} +#endif + +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 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 (Functor 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, 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, 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 + 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 :: Monad f => Free f a -> f a +retract (Pure a) = return a +retract (Free as) = as >>= retract + +-- | Tear down a 'Free' 'Monad' using iteration. +iter :: Functor 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, 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 (iterM phi <$> f) + +-- | 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, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) +unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) + +-- | This is @Prism' (Free f a) a@ in disguise +-- +-- >>> preview _Pure (Pure 3) +-- 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) (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 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 (Pure x) = Left (Pure x) + {-# INLINE unfree #-} +{-# INLINE _Free #-} + + +#if __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
@@ -1,449 +1,449 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"------------------------------------------------------------------------------------- |--- \"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.Compat-import Data.Foldable-import Data.Profunctor-import Data.Traversable-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Data-import Prelude hiding (foldr)-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics-#endif---- $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))-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable, Generic, Generic1)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Eq1 f) => Eq1 (Free f) where- Pure a `eq1` Pure b = a == b- Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb- _ `eq1` _ = False-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f, Eq a) => Eq (Free f a) where-#else-instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Ord1 f) => Ord1 (Free f) where- Pure a `compare1` Pure b = a `compare` b- Pure _ `compare1` Free _ = LT- Free _ `compare1` Pure _ = GT- Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f, Ord a) => Ord (Free f a) where-#else-instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Show1 f) => Show1 (Free f) where- showsPrec1 d (Pure a) = showParen (d > 10) $- showString "Pure " . showsPrec 11 a- showsPrec1 d (Free m) = showParen (d > 10) $- showString "Free " . showsPrec1 11 (fmap Lift1 m)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 f, Show a) => Show (Free f a) where-#else-instance (Show1 f, Functor f, Show a) => Show (Free f a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Read1 f) => Read1 (Free f) where- readsPrec1 d r = readParen (d > 10)- (\r' -> [ (Pure m, t)- | ("Pure", s) <- lex r'- , (m, t) <- readsPrec 11 s]) r- ++ readParen (d > 10)- (\r' -> [ (Free (fmap lower1 m), t)- | ("Free", s) <- lex r'- , (m, t) <- readsPrec1 11 s]) r-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 f, Read a) => Read (Free f a) where-#else-instance (Read1 f, Functor f, Read a) => Read (Free f a) where-#endif- 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 (Applicative v, 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 #-}--#if MIN_VERSION_base(4,6,0)- foldl' f = go where- go r free =- case free of- Pure a -> f r a- Free fa -> foldl' go r fa- {-# INLINE foldl' #-}-#endif--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 (Applicative 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 (Applicative m, MonadReader e m) => MonadReader e (Free m) where- ask = lift ask- {-# INLINE ask #-}- local f = lift . local f . retract- {-# INLINE local #-}--instance (Applicative m, MonadState s m) => MonadState s (Free m) where- get = lift get- {-# INLINE get #-}- put s = lift (put s)- {-# INLINE put #-}--instance (Applicative 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 (Applicative m, 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 :: (Applicative f, 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 :: (Applicative m, 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, Applicative m, 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, Applicative m, 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, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)-unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))---- | This is @Prism' (Free f a) a@ in disguise------ >>> preview _Pure (Pure 3)--- 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 #-}---#if __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+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +-------------------------------------------------------------------------------- +-- | +-- \"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.Compat +import Data.Foldable +import Data.Profunctor +import Data.Traversable +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Data +import Prelude hiding (foldr) +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics +#endif + +-- $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)) +#if __GLASGOW_HASKELL__ >= 707 + deriving (Typeable, Generic, Generic1) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Eq1 f) => Eq1 (Free f) where + Pure a `eq1` Pure b = a == b + Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb + _ `eq1` _ = False +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq a) => Eq (Free f a) where +#else +instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Ord1 f) => Ord1 (Free f) where + Pure a `compare1` Pure b = a `compare` b + Pure _ `compare1` Free _ = LT + Free _ `compare1` Pure _ = GT + Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord a) => Ord (Free f a) where +#else +instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Show1 f) => Show1 (Free f) where + showsPrec1 d (Pure a) = showParen (d > 10) $ + showString "Pure " . showsPrec 11 a + showsPrec1 d (Free m) = showParen (d > 10) $ + showString "Free " . showsPrec1 11 (fmap Lift1 m) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 f, Show a) => Show (Free f a) where +#else +instance (Show1 f, Functor f, Show a) => Show (Free f a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Read1 f) => Read1 (Free f) where + readsPrec1 d r = readParen (d > 10) + (\r' -> [ (Pure m, t) + | ("Pure", s) <- lex r' + , (m, t) <- readsPrec 11 s]) r + ++ readParen (d > 10) + (\r' -> [ (Free (fmap lower1 m), t) + | ("Free", s) <- lex r' + , (m, t) <- readsPrec1 11 s]) r +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 f, Read a) => Read (Free f a) where +#else +instance (Read1 f, Functor f, Read a) => Read (Free f a) where +#endif + 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 (Applicative v, 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 #-} + +#if MIN_VERSION_base(4,6,0) + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} +#endif + +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 (Applicative 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 (Applicative m, MonadReader e m) => MonadReader e (Free m) where + ask = lift ask + {-# INLINE ask #-} + local f = lift . local f . retract + {-# INLINE local #-} + +instance (Applicative m, MonadState s m) => MonadState s (Free m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + +instance (Applicative 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 (Applicative m, 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 :: (Applicative f, 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 :: (Applicative m, 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, Applicative m, 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, Applicative m, 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, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) +unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) + +-- | This is @Prism' (Free f a) a@ in disguise +-- +-- >>> preview _Pure (Pure 3) +-- 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 #-} + + +#if __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/Church.hs view
@@ -1,253 +1,253 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Safe #-}-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Monad.Free.Church--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : non-portable (rank-2 polymorphism)------ \"Free Monads for Less\"------ The most straightforward way of implementing free monads is as a recursive--- datatype that allows for arbitrarily deep nesting of the base functor. This is--- akin to a tree, with the leaves containing the values, and the nodes being a--- level of 'Functor' over subtrees.------ For each time that the `fmap` or `>>=` operations is used, the old tree is--- traversed up to the leaves, a new set of nodes is allocated, and--- the old ones are garbage collected. Even if the Haskell runtime--- optimizes some of the overhead through laziness and generational garbage--- collection, the asymptotic runtime is still quadratic.------ On the other hand, if the Church encoding is used, the tree only needs to be--- constructed once, because:------ * All uses of `fmap` are collapsed into a single one, so that the values on the--- _leaves_ are transformed in one pass.------ prop> fmap f . fmap g == fmap (f . g)------ * All uses of `>>=` are right associated, so that every new subtree created--- is final.------ prop> (m >>= f) >>= g == m >>= (\x -> f x >>= g)------ Asymptotically, the Church encoding supports the monadic operations more--- efficiently than the naïve 'Free'.------ This is based on the \"Free Monads for Less\" series of articles by Edward Kmett:------ * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1>------ * <http://comonad.com/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.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/>-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 => (f (m a) -> m a) -> F f a -> m a-iterM phi xs = runF xs return phi--instance Functor (F f) where- fmap f (F g) = F (\kp -> g (kp . f))--instance Apply (F f) where- (<.>) = (<*>)--instance Applicative (F f) where- pure a = F (\kp _ -> kp a)- 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)))--instance Bind (F f) where- (>>-) = (>>=)--instance Monad (F f) where- 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 #-}--#if MIN_VERSION_base(4,6,0)- foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z- {-# INLINE foldl' #-}-#endif--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)))--instance MonadTrans F where- lift f = F (\kp kf -> kf (liftM kp f))--instance Functor f => MonadFree f (F f) where- wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f))--instance MonadState s m => MonadState s (F m) where- get = lift get- put = lift . put--instance MonadReader e m => MonadReader e (F m) where- ask = lift ask- local f = lift . local f . retract--instance MonadWriter w m => MonadWriter w (F m) where- tell = lift . tell- pass = lift . pass . retract- listen = lift . listen . retract--instance MonadCont m => MonadCont (F m) where- callCC f = lift $ callCC (retract . f . fmap lift)---- |--- 'retract' is the left inverse of 'lift' and 'liftF'------ @--- 'retract' . 'lift' = 'id'--- 'retract' . 'liftF' = 'id'--- @-retract :: Monad m => F m a -> m a-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-{-# INLINE fromF #-}---- | Generate a Church-encoded free monad from a 'Free' monad.-toF :: Functor f => Free f a -> F f a-toF xs = F (\kp kf -> go kp kf xs) where- go kp _ (Pure a) = kp a- go kp kf (Free fma) = kf (fmap (go kp kf) fma)---- | 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:------ * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1>------ * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2>------ 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)+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free.Church +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : non-portable (rank-2 polymorphism) +-- +-- \"Free Monads for Less\" +-- +-- The most straightforward way of implementing free monads is as a recursive +-- datatype that allows for arbitrarily deep nesting of the base functor. This is +-- akin to a tree, with the leaves containing the values, and the nodes being a +-- level of 'Functor' over subtrees. +-- +-- For each time that the `fmap` or `>>=` operations is used, the old tree is +-- traversed up to the leaves, a new set of nodes is allocated, and +-- the old ones are garbage collected. Even if the Haskell runtime +-- optimizes some of the overhead through laziness and generational garbage +-- collection, the asymptotic runtime is still quadratic. +-- +-- On the other hand, if the Church encoding is used, the tree only needs to be +-- constructed once, because: +-- +-- * All uses of `fmap` are collapsed into a single one, so that the values on the +-- _leaves_ are transformed in one pass. +-- +-- prop> fmap f . fmap g == fmap (f . g) +-- +-- * All uses of `>>=` are right associated, so that every new subtree created +-- is final. +-- +-- prop> (m >>= f) >>= g == m >>= (\x -> f x >>= g) +-- +-- Asymptotically, the Church encoding supports the monadic operations more +-- efficiently than the naïve 'Free'. +-- +-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: +-- +-- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1> +-- +-- * <http://comonad.com/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.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/> +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 => (f (m a) -> m a) -> F f a -> m a +iterM phi xs = runF xs return phi + +instance Functor (F f) where + fmap f (F g) = F (\kp -> g (kp . f)) + +instance Apply (F f) where + (<.>) = (<*>) + +instance Applicative (F f) where + pure a = F (\kp _ -> kp a) + 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))) + +instance Bind (F f) where + (>>-) = (>>=) + +instance Monad (F f) where + 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 #-} + +#if MIN_VERSION_base(4,6,0) + foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z + {-# INLINE foldl' #-} +#endif + +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))) + +instance MonadTrans F where + lift f = F (\kp kf -> kf (liftM kp f)) + +instance Functor f => MonadFree f (F f) where + wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f)) + +instance MonadState s m => MonadState s (F m) where + get = lift get + put = lift . put + +instance MonadReader e m => MonadReader e (F m) where + ask = lift ask + local f = lift . local f . retract + +instance MonadWriter w m => MonadWriter w (F m) where + tell = lift . tell + pass = lift . pass . retract + listen = lift . listen . retract + +instance MonadCont m => MonadCont (F m) where + callCC f = lift $ callCC (retract . f . fmap lift) + +-- | +-- 'retract' is the left inverse of 'lift' and 'liftF' +-- +-- @ +-- 'retract' . 'lift' = 'id' +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad m => F m a -> m a +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 +{-# INLINE fromF #-} + +-- | Generate a Church-encoded free monad from a 'Free' monad. +toF :: Functor f => Free f a -> F f a +toF xs = F (\kp kf -> go kp kf xs) where + go kp _ (Pure a) = kp a + go kp kf (Free fma) = kf (fmap (go kp kf) fma) + +-- | 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: +-- +-- * <http://comonad.com/reader/2011/free-monads-for-less/ Free monads for less — Part 1> +-- +-- * <http://comonad.com/reader/2011/free-monads-for-less-2/ Free monads for less — Part 2> +-- +-- 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,170 +1,170 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeFamilies #-}-#endif-#if !(MIN_VERSION_transformers(0,6,0))-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Monad.Free.Class--- Copyright : (C) 2008-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable (fundeps, MPTCs)------ Monads for free.------------------------------------------------------------------------------module Control.Monad.Free.Class- ( MonadFree(..)- , liftF- , wrapT- ) where--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-import qualified Control.Monad.Trans.Writer.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity--#if !(MIN_VERSION_transformers(0,6,0))-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-#endif--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Monoid-#endif---- |--- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'):------ @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.------ @[]@ is not a free 'Monad' (in this sense) because @'Control.Monad.join' [[a]]@ smashes the lists flat.------ On the other hand, consider:------ @--- data Tree a = Bin (Tree a) (Tree a) | Tip a--- @------ @--- instance 'Monad' Tree where--- 'return' = Tip--- Tip a '>>=' f = f a--- Bin l r '>>=' f = Bin (l '>>=' f) (r '>>=' f)--- @------ This 'Monad' is the free 'Monad' of Pair:------ @--- data Pair a = Pair a a--- @------ And we could make an instance of 'MonadFree' for it directly:------ @--- instance 'MonadFree' Pair Tree where--- 'wrap' (Pair l r) = Bin l r--- @------ 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, "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-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704- default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a- wrap = join . lift . wrap . fmap return-#endif--instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where- wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm--instance (Functor f, MonadFree f m) => MonadFree f (Lazy.StateT s m) where- wrap fm = Lazy.StateT $ \s -> wrap $ flip Lazy.runStateT s <$> fm--instance (Functor f, MonadFree f m) => MonadFree f (Strict.StateT s m) where- wrap fm = Strict.StateT $ \s -> wrap $ flip Strict.runStateT s <$> fm--instance (Functor f, MonadFree f m) => MonadFree f (ContT r m) where- wrap t = ContT $ \h -> wrap (fmap (\p -> runContT p h) t)--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.WriterT w m) where- wrap = Lazy.WriterT . wrap . fmap Lazy.runWriterT--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.WriterT w m) where- wrap = Strict.WriterT . wrap . fmap Strict.runWriterT--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.RWST r w s m) where- wrap fm = Strict.RWST $ \r s -> wrap $ fmap (\m -> Strict.runRWST m r s) fm--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.RWST r w s m) where- wrap fm = Lazy.RWST $ \r s -> wrap $ fmap (\m -> Lazy.runRWST m r s) fm--instance (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where- wrap = MaybeT . wrap . fmap runMaybeT--instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where- wrap = IdentityT . wrap . fmap runIdentityT--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+{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +#endif +#if !(MIN_VERSION_transformers(0,6,0)) +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free.Class +-- Copyright : (C) 2008-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability : non-portable (fundeps, MPTCs) +-- +-- Monads for free. +---------------------------------------------------------------------------- +module Control.Monad.Free.Class + ( MonadFree(..) + , liftF + , wrapT + ) where + +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 +import qualified Control.Monad.Trans.Writer.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error +import Control.Monad.Trans.List +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +import Data.Monoid +#endif + +-- | +-- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'): +-- +-- @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. +-- +-- @[]@ is not a free 'Monad' (in this sense) because @'Control.Monad.join' [[a]]@ smashes the lists flat. +-- +-- On the other hand, consider: +-- +-- @ +-- data Tree a = Bin (Tree a) (Tree a) | Tip a +-- @ +-- +-- @ +-- instance 'Monad' Tree where +-- 'return' = Tip +-- Tip a '>>=' f = f a +-- Bin l r '>>=' f = Bin (l '>>=' f) (r '>>=' f) +-- @ +-- +-- This 'Monad' is the free 'Monad' of Pair: +-- +-- @ +-- data Pair a = Pair a a +-- @ +-- +-- And we could make an instance of 'MonadFree' for it directly: +-- +-- @ +-- instance 'MonadFree' Pair Tree where +-- 'wrap' (Pair l r) = Bin l r +-- @ +-- +-- 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, "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 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 + default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a + wrap = join . lift . wrap . fmap return +#endif + +instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where + wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm + +instance (Functor f, MonadFree f m) => MonadFree f (Lazy.StateT s m) where + wrap fm = Lazy.StateT $ \s -> wrap $ flip Lazy.runStateT s <$> fm + +instance (Functor f, MonadFree f m) => MonadFree f (Strict.StateT s m) where + wrap fm = Strict.StateT $ \s -> wrap $ flip Strict.runStateT s <$> fm + +instance (Functor f, MonadFree f m) => MonadFree f (ContT r m) where + wrap t = ContT $ \h -> wrap (fmap (\p -> runContT p h) t) + +instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.WriterT w m) where + wrap = Lazy.WriterT . wrap . fmap Lazy.runWriterT + +instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.WriterT w m) where + wrap = Strict.WriterT . wrap . fmap Strict.runWriterT + +instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.RWST r w s m) where + wrap fm = Strict.RWST $ \r s -> wrap $ fmap (\m -> Strict.runRWST m r s) fm + +instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.RWST r w s m) where + wrap fm = Lazy.RWST $ \r s -> wrap $ fmap (\m -> Lazy.runRWST m r s) fm + +instance (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where + wrap = MaybeT . wrap . fmap runMaybeT + +instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where + wrap = IdentityT . wrap . fmap runIdentityT + +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
@@ -1,475 +1,475 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}-#endif-#if MIN_VERSION_template_haskell(2,12,0)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif--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-#if MIN_VERSION_template_haskell(2,8,0)-extractVars (SigT x k) = extractVars x ++ extractVars k-#else-extractVars (SigT x k) = extractVars x-#endif-#if MIN_VERSION_template_haskell(2,11,0)-extractVars (InfixT x _ y) = extractVars x ++ extractVars y-extractVars (UInfixT x _ y) = extractVars x ++ extractVars y-extractVars (ParensT x) = extractVars x-#endif-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-#if MIN_VERSION_template_haskell(2,10,0)- then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ]-#else- then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ]-#endif- 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'-#if MIN_VERSION_template_haskell(2,11,0)- 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)-#endif- _ -> fail $ "Unsupported constructor type: `" ++ pprint con ++ "'"--#if MIN_VERSION_template_haskell(2,11,0)-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-#endif--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-#if MIN_VERSION_template_haskell(2,11,0)-constructorNames (GadtC names _ _) = names-constructorNames (RecGadtC names _ _) = names-#endif-constructorNames con' = fail $ "Unsupported constructor type: `" ++ pprint con' ++ "'"---- | 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]-#if MIN_VERSION_template_haskell(2,11,0)-liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _)-#else-liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _)-#endif- | 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-#if !(MIN_VERSION_template_haskell(2,11,0))- _-#endif- -> 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)---}+{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +#endif +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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 + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif + +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 +#if MIN_VERSION_template_haskell(2,8,0) +extractVars (SigT x k) = extractVars x ++ extractVars k +#else +extractVars (SigT x k) = extractVars x +#endif +#if MIN_VERSION_template_haskell(2,11,0) +extractVars (InfixT x _ y) = extractVars x ++ extractVars y +extractVars (UInfixT x _ y) = extractVars x ++ extractVars y +extractVars (ParensT x) = extractVars x +#endif +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 +#if MIN_VERSION_template_haskell(2,10,0) + then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ] +#else + then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ] +#endif + 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' +#if MIN_VERSION_template_haskell(2,11,0) + 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) +#endif + _ -> fail $ "Unsupported constructor type: `" ++ pprint con ++ "'" + +#if MIN_VERSION_template_haskell(2,11,0) +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 +#endif + +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 +#if MIN_VERSION_template_haskell(2,11,0) +constructorNames (GadtC names _ _) = names +constructorNames (RecGadtC names _ _) = names +#endif +constructorNames con' = fail $ "Unsupported constructor type: `" ++ pprint con' ++ "'" + +-- | 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] +#if MIN_VERSION_template_haskell(2,11,0) +liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _) +#else +liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _) +#endif + | 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 +#if !(MIN_VERSION_template_haskell(2,11,0)) + _ +#endif + -> 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,612 +1,612 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- Module : Control.Monad.Trans.Free--- 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 free monad transformer---------------------------------------------------------------------------------module Control.Monad.Trans.Free- (- -- * The base functor- FreeF(..)- -- * The free monad transformer- , FreeT(..)- -- * 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, 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 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.Compat-import Data.Functor.Identity-import Data.Traversable-import Data.Bifunctor-import Data.Bifoldable-import Data.Bitraversable-import Data.Data-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics-#endif--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable-import Data.Monoid-#endif---- | 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 ,Generic ,Generic1-#endif- )--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Show1 f, Show a) => Show1 (FreeF f a) where- showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a- showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Read1 f, Read a) => Read1 (FreeF f a) where- readsPrec1 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) <- readsPrec1 11 s]) r-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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 (==)-#else-instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where- Pure a `eq1` Pure b = a == b- Free as `eq1` Free bs = as `eq1` bs- _ `eq1` _ = False-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where- Pure a `compare1` Pure b = a `compare` b- Pure _ `compare1` Free _ = LT- Free _ `compare1` Pure _ = GT- Free fa `compare1` Free fb = fa `compare1` fb-#endif--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@-newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) }---- | The \"free monad\" for a functor @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 #-}--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where-#else-instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where- eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where-#else-instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where- compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where- showsPrec1 d (FreeT m) = showParen (d > 10) $- showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where-#else-instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where-#else-instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where-#endif- readsPrec = readsPrec1--instance (Functor f, Monad m) => Functor (FreeT f m) where- fmap f (FreeT m) = FreeT (liftM f' m) where- f' (Pure a) = Pure (f a)- f' (Free as) = Free (fmap (fmap f) as)--instance (Functor f, Monad m) => Applicative (FreeT f m) where- pure a = FreeT (return (Pure a))- {-# INLINE pure #-}- (<*>) = 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 = 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 (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 #-}--instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where- 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, Functor m, MonadReader r m) => MonadReader r (FreeT f m) where- ask = lift ask- {-# INLINE ask #-}- local f = hoistFreeT (local f)- {-# INLINE local #-}--instance (Functor f, Functor m, 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-#if MIN_VERSION_mtl(2,1,1)- writer w = lift (writer w)- {-# INLINE writer #-}-#endif--instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1)- state f = lift (state f)- {-# INLINE state #-}-#endif--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)- {-# INLINE (<|>) #-}--instance (Functor 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 (Functor f, Monad m) => MonadFree f (FreeT f m) where- 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- val <- m- case fmap (iterT f) val of- 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--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, '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---- | 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---- | Pull out and join @m@ layers of @'FreeT' f m a@.-joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a)-joinFreeT (FreeT m) = m >>= joinFreeF- where- joinFreeF (Pure x) = return (return x)- joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f---- |--- 'retract' is the left inverse of 'liftF'------ @--- '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---- | 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)---- | 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)---- | 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---- | @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, 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--- @-#if __GLASGOW_HASKELL__ < 710-intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b-#else-intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b-#endif-intercalateT f (FreeT m) = do- val <- lift m- case val of- Pure x -> return x- Free y -> y >>= iterTM (\x -> f >> join x)--#if __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--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--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 #-}--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--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--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 #-}--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+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Free +-- 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 free monad transformer +-- +---------------------------------------------------------------------------- +module Control.Monad.Trans.Free + ( + -- * The base functor + FreeF(..) + -- * The free monad transformer + , FreeT(..) + -- * 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, 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 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.Compat +import Data.Functor.Identity +import Data.Traversable +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable +import Data.Monoid +#endif + +-- | 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 ,Generic ,Generic1 +#endif + ) + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Show1 f, Show a) => Show1 (FreeF f a) where + showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a + showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Read1 f, Read a) => Read1 (FreeF f a) where + readsPrec1 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) <- readsPrec1 11 s]) r +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 (==) +#else +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + Pure a `eq1` Pure b = a == b + Free as `eq1` Free bs = as `eq1` bs + _ `eq1` _ = False +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + Pure a `compare1` Pure b = a `compare` b + Pure _ `compare1` Free _ = LT + Free _ `compare1` Pure _ = GT + Free fa `compare1` Free fb = fa `compare1` fb +#endif + +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@ +newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) } + +-- | The \"free monad\" for a functor @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 #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where +#else +instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where + eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where +#else +instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where + compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where + showsPrec1 d (FreeT m) = showParen (d > 10) $ + showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where +#else +instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where + readsPrec1 d = readParen (d > 10) $ \r -> + [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s] +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where +#else +instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where +#endif + readsPrec = readsPrec1 + +instance (Functor f, Monad m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (liftM f' m) where + f' (Pure a) = Pure (f a) + f' (Free as) = Free (fmap (fmap f) as) + +instance (Functor f, Monad m) => Applicative (FreeT f m) where + pure a = FreeT (return (Pure a)) + {-# INLINE pure #-} + (<*>) = 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 = 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 (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 #-} + +instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where + 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, Functor m, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Functor f, Functor m, 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 +#if MIN_VERSION_mtl(2,1,1) + writer w = lift (writer w) + {-# INLINE writer #-} +#endif + +instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} +#if MIN_VERSION_mtl(2,1,1) + state f = lift (state f) + {-# INLINE state #-} +#endif + +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) + {-# INLINE (<|>) #-} + +instance (Functor 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 (Functor f, Monad m) => MonadFree f (FreeT f m) where + 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 + val <- m + case fmap (iterT f) val of + 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 + +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, '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 + +-- | 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 + +-- | Pull out and join @m@ layers of @'FreeT' f m a@. +joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a) +joinFreeT (FreeT m) = m >>= joinFreeF + where + joinFreeF (Pure x) = return (return x) + joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f + +-- | +-- 'retract' is the left inverse of 'liftF' +-- +-- @ +-- '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 + +-- | 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) + +-- | 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) + +-- | 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 + +-- | @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, 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 +-- @ +#if __GLASGOW_HASKELL__ < 710 +intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b +#else +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +#endif +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) + +#if __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 + +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 + +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 #-} + +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 + +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 + +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 #-} + +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
src/Control/Monad/Trans/Free/Ap.hs view
@@ -1,600 +1,600 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"------------------------------------------------------------------------------------- |--- 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.Compat-import Data.Functor.Identity-import Data.Traversable-import Data.Bifunctor-import Data.Bifoldable-import Data.Bitraversable-import Data.Data-#if __GLASGOW_HASKELL__ >= 707-import GHC.Generics-#endif--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable-import Data.Monoid-#endif---- | 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 ,Generic, Generic1-#endif- )--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Show1 f, Show a) => Show1 (FreeF f a) where- showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a- showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Read1 f, Read a) => Read1 (FreeF f a) where- readsPrec1 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) <- readsPrec1 11 s]) r-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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 (==)-#else-instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where- Pure a `eq1` Pure b = a == b- Free as `eq1` Free bs = as `eq1` bs- _ `eq1` _ = False-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where- Pure a `compare1` Pure b = a `compare` b- Pure _ `compare1` Free _ = LT- Free _ `compare1` Pure _ = GT- Free fa `compare1` Free fb = fa `compare1` fb-#endif--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 #-}--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where-#else-instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where- eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where-#else-instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where- compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where- showsPrec1 d (FreeT m) = showParen (d > 10) $- showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where-#else-instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where-#else-instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where-#endif- readsPrec = readsPrec1--instance (Functor f, Monad m) => Functor (FreeT f m) where- fmap f (FreeT m) = FreeT (liftM f' m) where- f' (Pure a) = Pure (f a)- f' (Free as) = Free (fmap (fmap f) as)--instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where- pure a = FreeT (return (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, Monad 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, Applicative m, 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, Applicative m, 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, Applicative m, MonadIO m) => MonadIO (FreeT f m) where- liftIO = lift . liftIO- {-# INLINE liftIO #-}--instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where- ask = lift ask- {-# INLINE ask #-}- local f = hoistFreeT (local f)- {-# INLINE local #-}--instance (Applicative f, Applicative m, 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-#if MIN_VERSION_mtl(2,1,1)- writer w = lift (writer w)- {-# INLINE writer #-}-#endif--instance (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1)- state f = lift (state f)- {-# INLINE state #-}-#endif--instance (Applicative f, Applicative m, 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, Applicative m, MonadCont m) => MonadCont (FreeT f m) where- callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))--instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where- empty = FreeT mzero- FreeT ma <|> FreeT mb = FreeT (mplus ma mb)- {-# INLINE (<|>) #-}--instance (Applicative f, Applicative m, 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, Applicative m, Monad m) => MonadFree f (FreeT f m) where- wrap = FreeT . return . Free- {-# INLINE wrap #-}--instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where- throwM = lift . throwM- {-# INLINE throwM #-}--instance (Applicative f, Applicative m, 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, Applicative m, 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 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--- @-#if __GLASGOW_HASKELL__ < 710-intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b-#else-intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b-#endif-intercalateT f (FreeT m) = do- val <- lift m- case val of- Pure x -> return x- Free y -> y >>= iterTM (\x -> f >> join x)--#if __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--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--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 #-}--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--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--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 #-}--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+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +-------------------------------------------------------------------------------- +-- | +-- 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.Compat +import Data.Functor.Identity +import Data.Traversable +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Generics +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable +import Data.Monoid +#endif + +-- | 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 ,Generic, Generic1 +#endif + ) + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Show1 f, Show a) => Show1 (FreeF f a) where + showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a + showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Read1 f, Read a) => Read1 (FreeF f a) where + readsPrec1 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) <- readsPrec1 11 s]) r +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 (==) +#else +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + Pure a `eq1` Pure b = a == b + Free as `eq1` Free bs = as `eq1` bs + _ `eq1` _ = False +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + Pure a `compare1` Pure b = a `compare` b + Pure _ `compare1` Free _ = LT + Free _ `compare1` Pure _ = GT + Free fa `compare1` Free fb = fa `compare1` fb +#endif + +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 #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where +#else +instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where + eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where +#else +instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where + compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where + showsPrec1 d (FreeT m) = showParen (d > 10) $ + showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where +#else +instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where + readsPrec1 d = readParen (d > 10) $ \r -> + [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s] +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where +#else +instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where +#endif + readsPrec = readsPrec1 + +instance (Functor f, Monad m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (liftM f' m) where + f' (Pure a) = Pure (f a) + f' (Free as) = Free (fmap (fmap f) as) + +instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where + pure a = FreeT (return (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, Monad 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, Applicative m, 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, Applicative m, 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, Applicative m, MonadIO m) => MonadIO (FreeT f m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Applicative f, Applicative m, 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 +#if MIN_VERSION_mtl(2,1,1) + writer w = lift (writer w) + {-# INLINE writer #-} +#endif + +instance (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} +#if MIN_VERSION_mtl(2,1,1) + state f = lift (state f) + {-# INLINE state #-} +#endif + +instance (Applicative f, Applicative m, 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, Applicative m, MonadCont m) => MonadCont (FreeT f m) where + callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) + +instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where + empty = FreeT mzero + FreeT ma <|> FreeT mb = FreeT (mplus ma mb) + {-# INLINE (<|>) #-} + +instance (Applicative f, Applicative m, 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, Applicative m, Monad m) => MonadFree f (FreeT f m) where + wrap = FreeT . return . Free + {-# INLINE wrap #-} + +instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance (Applicative f, Applicative m, 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, Applicative m, 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 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 +-- @ +#if __GLASGOW_HASKELL__ < 710 +intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b +#else +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +#endif +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) + +#if __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 + +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 + +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 #-} + +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 + +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 + +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 #-} + +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
src/Control/Monad/Trans/Free/Church.hs view
@@ -1,333 +1,338 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE UndecidableInstances #-}-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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 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.Compat--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-#endif---- | The \"free monad transformer\" for a functor @f@-newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r }--#ifdef LIFTED_FUNCTOR_CLASSES-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)-#else-instance ( Functor f, Monad m, Eq1 f, Eq1 m-# if !(MIN_VERSION_base(4,8,0))- , Functor m-# endif- ) => Eq1 (FT f m) where- eq1 x y = eq1 (fromFT x) (fromFT y)--instance ( Functor f, Monad m, Ord1 f, Ord1 m-# if !(MIN_VERSION_base(4,8,0))- , Functor m-# endif- ) => Ord1 (FT f m) where- compare1 x y = compare1 (fromFT x) (fromFT y)-#endif--instance ( Functor f, Monad m, Eq1 f, Eq1 m-# if !(MIN_VERSION_base(4,8,0))- , Functor m-# endif- , Eq a- ) => Eq (FT f m a) where- (==) = eq1--instance ( Functor f, Monad m, Ord1 f, Ord1 m-# if !(MIN_VERSION_base(4,8,0))- , Functor m-# endif- , 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 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 #-}--#if MIN_VERSION_base(4,6,0)- foldl' f z xs = F.foldl' (!>>>) id inner z- where- (!>>>) h g = \r -> g $! h r- inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf)- {-# INLINE foldl' #-}-#endif--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, Functor m, MonadWriter w m) => MonadWriter w (FT f m) where- tell = lift . tell- {-# INLINE tell #-}- listen = toFT . listen . fromFT- pass = toFT . pass . fromFT-#if MIN_VERSION_mtl(2,1,1)- writer w = lift (writer w)- {-# INLINE writer #-}-#endif--instance MonadState s m => MonadState s (FT f m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1)- state f = lift (state f)- {-# INLINE state #-}-#endif--instance MonadThrow m => MonadThrow (FT f m) where- throwM = lift . throwM- {-# INLINE throwM #-}--instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where- catch m f = toFT $ fromFT m `Control.Monad.Catch.catch` (fromFT . f)- {-# INLINE catch #-}---- | Generate a Church-encoded free monad transformer from a 'FreeT' monad--- transformer.-toFT :: Monad m => 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'--- @-#if __GLASGOW_HASKELL__ < 710-retract :: (Functor f, Monad f) => F f a -> f a-#else-retract :: Monad f => F f a -> f a-#endif-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:------ <http://comonad.com/reader/2011/free-monads-for-less/>--- <http://comonad.com/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 #-}-+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE UndecidableInstances #-} +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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.Compat + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +#endif + +-- | The \"free monad transformer\" for a functor @f@ +newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r } + +#ifdef LIFTED_FUNCTOR_CLASSES +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) +#else +instance ( Functor f, Monad m, Eq1 f, Eq1 m +# if !(MIN_VERSION_base(4,8,0)) + , Functor m +# endif + ) => Eq1 (FT f m) where + eq1 x y = eq1 (fromFT x) (fromFT y) + +instance ( Functor f, Monad m, Ord1 f, Ord1 m +# if !(MIN_VERSION_base(4,8,0)) + , Functor m +# endif + ) => Ord1 (FT f m) where + compare1 x y = compare1 (fromFT x) (fromFT y) +#endif + +instance ( Functor f, Monad m, Eq1 f, Eq1 m +# if !(MIN_VERSION_base(4,8,0)) + , Functor m +# endif + , Eq a + ) => Eq (FT f m a) where + (==) = eq1 + +instance ( Functor f, Monad m, Ord1 f, Ord1 m +# if !(MIN_VERSION_base(4,8,0)) + , Functor m +# endif + , 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 #-} + +#if MIN_VERSION_base(4,6,0) + foldl' f z xs = F.foldl' (!>>>) id inner z + where + (!>>>) h g = \r -> g $! h r + inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf) + {-# INLINE foldl' #-} +#endif + +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, Functor m, MonadWriter w m) => MonadWriter w (FT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen = toFT . listen . fromFT + pass = toFT . pass . fromFT +#if MIN_VERSION_mtl(2,1,1) + writer w = lift (writer w) + {-# INLINE writer #-} +#endif + +instance MonadState s m => MonadState s (FT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} +#if MIN_VERSION_mtl(2,1,1) + state f = lift (state f) + {-# INLINE state #-} +#endif + +instance MonadThrow m => MonadThrow (FT f m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where + catch m f = toFT $ fromFT m `Control.Monad.Catch.catch` (fromFT . f) + {-# INLINE catch #-} + +-- | Generate a Church-encoded free monad transformer from a 'FreeT' monad +-- transformer. +toFT :: Monad m => 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' +-- @ +#if __GLASGOW_HASKELL__ < 710 +retract :: (Functor f, Monad f) => F f a -> f a +#else +retract :: Monad f => F f a -> f a +#endif +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: +-- +-- <http://comonad.com/reader/2011/free-monads-for-less/> +-- <http://comonad.com/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
@@ -1,523 +1,523 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else--- Manual Typeable instances-{-# LANGUAGE Trustworthy #-}-#endif-#include "free-common.h"---------------------------------------------------------------------------------- |--- 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.Compat-import Data.Functor.Identity-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Typeable-import Data.Data--#if !(MIN_VERSION_base(4,8,0))-import Data.Foldable hiding (fold)-import Data.Traversable hiding (mapM)-#endif--#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)) }-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable)-#endif---- | 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 #-}--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 m) => Eq1 (IterT m) where- liftEq eq = go- where- go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y-#else-instance (Functor m, Eq1 m) => Eq1 (IterT m) where- eq1 = on eq1 (fmap (fmap Lift1) . runIterT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Eq1 m, Eq a) => Eq (IterT m a) where-#else-instance (Functor m, Eq1 m, Eq a) => Eq (IterT m a) where-#endif- (==) = eq1--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 m) => Ord1 (IterT m) where- liftCompare cmp = go- where- go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y-#else-instance (Functor m, Ord1 m) => Ord1 (IterT m) where- compare1 = on compare1 (fmap (fmap Lift1) . runIterT)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Ord1 m, Ord a) => Ord (IterT m a) where-#else-instance (Functor m, Ord1 m, Ord a) => Ord (IterT m a) where-#endif- compare = compare1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor m, Show1 m) => Show1 (IterT m) where- showsPrec1 d (IterT m) = showParen (d > 10) $- showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m)-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Show1 m, Show a) => Show (IterT m a) where-#else-instance (Functor m, Show1 m, Show a) => Show (IterT m a) where-#endif- showsPrec = showsPrec1--#ifdef LIFTED_FUNCTOR_CLASSES-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-#else-instance (Functor m, Read1 m) => Read1 (IterT m) where- readsPrec1 d = readParen (d > 10) $ \r ->- [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s]-#endif--#ifdef LIFTED_FUNCTOR_CLASSES-instance (Read1 m, Read a) => Read (IterT m a) where-#else-instance (Functor m, Read1 m, Read a) => Read (IterT m a) where-#endif- 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-#if MIN_VERSION_mtl(2,1,1)- writer w = lift (writer w)- {-# INLINE writer #-}-#endif--instance MonadState s m => MonadState s (IterT m) where- get = lift get- {-# INLINE get #-}- put s = lift (put s)- {-# INLINE put #-}-#if MIN_VERSION_mtl(2,1,1)- state f = lift (state f)- {-# INLINE state #-}-#endif--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--#if __GLASGOW_HASKELL__ < 707-instance Typeable1 m => Typeable1 (IterT m) where- typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where- f :: IterT m a -> m a- f = undefined--freeTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-freeTyCon = mkTyCon "Control.Monad.Iter.IterT"-#else-freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT"-#endif-{-# NOINLINE freeTyCon #-}--#else-#define Typeable1 Typeable-#endif--instance- ( Typeable1 m, Typeable a- , Data (m (Either a (IterT m a)))- , Data a- ) => Data (IterT m a) where- gfoldl f z (IterT as) = z IterT `f` as- toConstr IterT{} = iterConstr- gunfold k z c = case constrIndex c of- 1 -> k (z IterT)- _ -> error "gunfold"- dataTypeOf _ = iterDataType- dataCast1 f = gcast1 f--iterConstr :: Constr-iterConstr = mkConstr iterDataType "IterT" [] Prefix-{-# NOINLINE iterConstr #-}--iterDataType :: DataType-iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr]-{-# NOINLINE iterDataType #-}--{- $examples--* <examples/MandelbrotIter.lhs Rendering the Mandelbrot set>--* <examples/Cabbage.lhs The wolf, the sheep and the cabbage>---}+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +#else +-- Manual Typeable instances +{-# LANGUAGE Trustworthy #-} +#endif +#include "free-common.h" + +----------------------------------------------------------------------------- +-- | +-- 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.Compat +import Data.Functor.Identity +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Typeable +import Data.Data + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable hiding (fold) +import Data.Traversable hiding (mapM) +#endif + +#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)) } +#if __GLASGOW_HASKELL__ >= 707 + deriving (Typeable) +#endif + +-- | 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 #-} + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 m) => Eq1 (IterT m) where + liftEq eq = go + where + go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y +#else +instance (Functor m, Eq1 m) => Eq1 (IterT m) where + eq1 = on eq1 (fmap (fmap Lift1) . runIterT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 m, Eq a) => Eq (IterT m a) where +#else +instance (Functor m, Eq1 m, Eq a) => Eq (IterT m a) where +#endif + (==) = eq1 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 m) => Ord1 (IterT m) where + liftCompare cmp = go + where + go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y +#else +instance (Functor m, Ord1 m) => Ord1 (IterT m) where + compare1 = on compare1 (fmap (fmap Lift1) . runIterT) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 m, Ord a) => Ord (IterT m a) where +#else +instance (Functor m, Ord1 m, Ord a) => Ord (IterT m a) where +#endif + compare = compare1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor m, Show1 m) => Show1 (IterT m) where + showsPrec1 d (IterT m) = showParen (d > 10) $ + showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Show1 m, Show a) => Show (IterT m a) where +#else +instance (Functor m, Show1 m, Show a) => Show (IterT m a) where +#endif + showsPrec = showsPrec1 + +#ifdef LIFTED_FUNCTOR_CLASSES +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 +#else +instance (Functor m, Read1 m) => Read1 (IterT m) where + readsPrec1 d = readParen (d > 10) $ \r -> + [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s] +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Read1 m, Read a) => Read (IterT m a) where +#else +instance (Functor m, Read1 m, Read a) => Read (IterT m a) where +#endif + 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 +#if MIN_VERSION_mtl(2,1,1) + writer w = lift (writer w) + {-# INLINE writer #-} +#endif + +instance MonadState s m => MonadState s (IterT m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} +#if MIN_VERSION_mtl(2,1,1) + state f = lift (state f) + {-# INLINE state #-} +#endif + +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 + +#if __GLASGOW_HASKELL__ < 707 +instance Typeable1 m => Typeable1 (IterT m) where + typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where + f :: IterT m a -> m a + f = undefined + +freeTyCon :: TyCon +#if __GLASGOW_HASKELL__ < 704 +freeTyCon = mkTyCon "Control.Monad.Iter.IterT" +#else +freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT" +#endif +{-# NOINLINE freeTyCon #-} + +#else +#define Typeable1 Typeable +#endif + +instance + ( Typeable1 m, Typeable a + , Data (m (Either a (IterT m a))) + , Data a + ) => Data (IterT m a) where + gfoldl f z (IterT as) = z IterT `f` as + toConstr IterT{} = iterConstr + gunfold k z c = case constrIndex c of + 1 -> k (z IterT) + _ -> error "gunfold" + dataTypeOf _ = iterDataType + dataCast1 f = gcast1 f + +iterConstr :: Constr +iterConstr = mkConstr iterDataType "IterT" [] Prefix +{-# NOINLINE iterConstr #-} + +iterDataType :: DataType +iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr] +{-# NOINLINE iterDataType #-} + +{- $examples + +* <examples/MandelbrotIter.lhs Rendering the Mandelbrot set> + +* <examples/Cabbage.lhs The wolf, the sheep and the cabbage> + +-}
src/Data/Functor/Classes/Compat.hs view
@@ -1,45 +1,45 @@-#include "free-common.h"-#ifdef LIFTED_FUNCTOR_CLASSES-{-# LANGUAGE Safe #-}-module Data.Functor.Classes.Compat (- mappend,- module Data.Functor.Classes,- ) where--import Data.Functor.Classes--#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (mappend)-#endif-#else-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE Trustworthy #-}-module Data.Functor.Classes.Compat (- Lift1 (..),- on,- module Data.Functor.Classes,- ) where------------------------------------------------------------------------------------ transformers-0.4 helpers, copied from prelude-extras----------------------------------------------------------------------------------# if !(MIN_VERSION_base(4,8,0))-import Data.Foldable-import Data.Traversable-# endif-import Data.Functor.Classes-import Data.Function (on)---- If Show1 and Read1 are ever derived by the same mechanism as--- Show and Read, rather than GND, that will change their behavior--- here.-newtype Lift1 f a = Lift1 { lower1 :: f a }- deriving (Functor, Foldable, Traversable, Eq1, Ord1, Show1, Read1)--instance (Eq1 f, Eq a) => Eq (Lift1 f a) where (==) = eq1-instance (Ord1 f, Ord a) => Ord (Lift1 f a) where compare = compare1-instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec = showsPrec1-instance (Read1 f, Read a) => Read (Lift1 f a) where readsPrec = readsPrec1-#endif+#include "free-common.h" +#ifdef LIFTED_FUNCTOR_CLASSES +{-# LANGUAGE Safe #-} +module Data.Functor.Classes.Compat ( + mappend, + module Data.Functor.Classes, + ) where + +import Data.Functor.Classes + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mappend) +#endif +#else +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} +module Data.Functor.Classes.Compat ( + Lift1 (..), + on, + module Data.Functor.Classes, + ) where + +------------------------------------------------------------------------------- +-- transformers-0.4 helpers, copied from prelude-extras +------------------------------------------------------------------------------- + +# if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable +import Data.Traversable +# endif +import Data.Functor.Classes +import Data.Function (on) + +-- If Show1 and Read1 are ever derived by the same mechanism as +-- Show and Read, rather than GND, that will change their behavior +-- here. +newtype Lift1 f a = Lift1 { lower1 :: f a } + deriving (Functor, Foldable, Traversable, Eq1, Ord1, Show1, Read1) + +instance (Eq1 f, Eq a) => Eq (Lift1 f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (Lift1 f a) where compare = compare1 +instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec = showsPrec1 +instance (Read1 f, Read a) => Read (Lift1 f a) where readsPrec = readsPrec1 +#endif