diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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.* diff --git a/.hlint.yaml b/.hlint.yaml --- a/.hlint.yaml +++ b/.hlint.yaml @@ -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} diff --git a/.vim.custom b/.vim.custom --- a/.vim.custom +++ b/.vim.custom @@ -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 :exec ":!hasktags -x -c --ignore src" - -" 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 :exec ":!hasktags -x -c --ignore src" + +" 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" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,228 +1,238 @@ -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. +5.2 [2023.03.12] +---------------- +* Drop support for GHC 7.10 and earlier. +* Drop redundant `Monad` constraints on many functions and instances. These + constraints were only present for compatibility with pre-7.10 versions of + GHC, which `free` no longer supports. +* Add `Eq`, `Eq1`, `Ord`, `Ord1`, and `Foldable` instances for `Ap` in + `Control.Applicative.Free`. +* Switch out `bifunctors` dependency for `bifunctor-classes-compat`. + +5.1.10 [2022.11.30] +------------------- +* Add a `MonadFail` instance for `FT`. + +5.1.9 [2022.06.26] +------------------ +* Simplify the `Eq` and `Ord` instances for `FT` to avoid the use of + overlapping instances. + +5.1.8 [2022.05.07] +------------------ +* Generalize the `Monad` constraint in the type signatures for + `hoistFreeT` in `Control.Monad.Trans.Free` and `Control.Monad.Trans.Free.Ap` + to a `Functor` constraint. +* Allow building with `transformers-0.6.*` and `mtl-2.3.*`. + +5.1.7 [2021.04.30] +------------------ +* Enable `FlexibleContexts` in `Control.Monad.Trans.Free.Church` to allow + building with GHC 9.2. + +5.1.6 [2020.12.31] +------------------ +* Explicitly mark modules as `Safe`. + +5.1.5 [2020.12.16] +------------------ +* Move `indexed-traversable` (`FunctorWithIndex` etc) instances from `lens`. + +5.1.4 [2020.10.01] +------------------ +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). + +5.1.3 [2019.11.26] +------------------ +* Allow building with `template-haskell-2.16` (GHC 8.10). +* Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for + `CofreeF`. + +5.1.2 [2019.08.27] +------------------ +* Implement more performant versions of `some` and `many` in the `Alternative` + instance for the final `Alt` encoding. + +5.1.1 [2019.05.02] +------------------ +* Allow building with `base-4.13` (GHC 8.8). + +5.1 [2018.07.03] +---------------- +* Generalize the type of `_Free`. +* Allow building with `containers-0.6`. +* Avoid incurring some dependencies when using recent GHCs. + +5.0.2 [2018.04.25] +------------------ +* Add `Generic` and `Generic1` instances where possible. + +5.0.1 [2018.03.07] +------------------ +* Fix the build on old GHCs with `transformers-0.4`. + +5 [2018.01.28] +-------------- +* Add a `Semigroup` instance for `IterT`. +* Add `MonadFail` instances for `IterT` and `FreeT`. +* Add a `Comonad` instance for the free `Applicative`, `Ap`. +* Add `Control.Monad.Free.Ap` and `Control.Monad.Trans.Free.Ap` modules, based + on the "Applicative Effects in Free Monads" series of articles by Will + Fancher. +* Derive `Data` instances for `Free` and `Cofree`. +* `Control.Monad.Free.TH` now properly supports `template-haskell-2.11.0.0`. In + particular, it now supports `GadtC` and `RecGadtC`, which are new + `template-haskell` forms for representing GADTs. +* Add `telescoped_`, `shoots`, and `leaves` to `Control.Comonad.Cofree` +* Add the `Control.Applicative.Free.Fast` module, based on Dave Menendez's + article "Free Applicative Functors in Haskell" +* Add `foldFreeT` to `Control.Monad.Trans.Free` +* Improve the `foldMap` and `cutoff` functions for + `Control.Monad.Free.Church.F`, and add a `Traversable` +* Add a `MonadBase` instance for `FreeT` +* Add a performance test comparing Free and Church interpreters +* The use of `prelude-extras` has been removed. `free` now uses the + `Data.Functor.Classes` module to give `free`'s datatypes instances of `Eq1`, + `Ord1`, `Read1`, and `Show1`. Their `Eq`, `Ord`, `Read`, and `Show` instances + have also been modified to incorporate these classes. For example, what + previously existed as: + + ```haskell + instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where + ``` + + has now been changed to: + + ```haskell + instance (Eq1 f, Eq a) => Eq (Free f a) where + ``` +* Remove redundant `Functor` constraints from `Control.Alternative.Free` + +4.12.4 +------ +* Removed a number of spurious class constraints. +* Support GHC 8 + +4.12.3 +------ +* Support `comonad` 5 + +4.12.2 +------ +* Add instances for `ExceptT`: like `ErrorT`, but without an `Error` constraint. +* Support `containers` +* Support `transformers` 0.5 + + +4.12.1 +------ +* Support GHC 7.4 + +4.12 +---- +* Add instances of `MonadCatch` and `MonadThrow` from `exceptions` to `FT`, `FreeT` and `IterT`. +* `semigroupoids` 5, `profunctors` 5, and `bifunctors` 5 support. + +4.11 +----- +* Pass Monad[FreeT].fail into underlying monad +* Add `retractT`. +* Added `cutoff` for the church encoded free monad. +* `cutoff` now accepts negative numbers. +* Added `intersperseT` and `intercalateT`. +* Added `foldFree` and `foldF`. +* Added some new `template-haskell` toys. + +4.10.0.1 +------ +* Fix for very old `cabal` versions where the `MIN_VERSION_foo` macros aren't negation friendly. + +4.10 +---- +* Redefine `Alternative` and `MonadPlus` instances of `IterT` so that they apply to any underlying `Monad`. + `mplus` or `<|>` is Capretta's `race` combinator; `mzero` or `empty` is a non-terminating computation. +* Redefine `fail s` for `IterT` as `mzero`, for any string `s`. +* Added `Control.Monad.Trans.Iter.untilJust`, which repeatedly retries a `m (Maybe a)` computation until + it produces `Just` a value. +* Fix things so that we can build with GHC 7.10, which also uses the name `Alt` in `Data.Monoid`, and which exports `Monoid` from `Prelude`. + +4.9 +--- +* Remove `either` support. Why? It dragged in a large number of dependencies we otherwise don't support, and so is probably best inverted. + +4.8.0.1 +------- +* Allow complation with older versions of `base`. (Foldable didn't add foldl' until base 4.6) + +4.8 +----- +* Added a `MonadFree` instance for `EitherT` (frrom the `either` package). +* Support for `transformers` 0.4 + +4.7.1 +----- +* Added more versions of `cutoff`. + +4.7 +--- +* Added `prelude-extras` support. This makes it possible to work without `UndecidableInstances` for most operations. +* Removed the `GHC_TYPEABLE` flag. + +4.6.1 +----- +* Added `hoistF` + +4.6 +--- +* Víctor López Juan and Fabian Ruch added many documentation improvements and a whole host of proofs of correctness. +* Improvements in the template haskell code generator. +* Added instances for `MonadWriter` and `MonadCont` where appropriate, thanks to Nickolay Kudasov. +* Added `cutoff`, `iterTM`, and `never`. +* Made modifications to some `Typeable` and `Data` instances to work correctly on both GHC 7.8.1rc1 and 7.8.1rc2. +* Removed `Control.MonadPlus.Free`. Use `FreeT f []` instead and the result will be law-abiding. +* Replaced `Control.Alternative.Free` with a new approach that is law-abiding for left-distributive Alternatives. + +4.5 +----- +* Added `Control.Monad.Free.TH` with `makeFree` to make it easier to write free monads. +* Added missing instances for `MonadFix` and `MonadCont` where appropriate. + +4.2 +----- +* Added `Control.Monad.Trans.Iter` and `Control.Comonad.Trans.Coiter`. + +4.1.1 +----- +* Added a default signature to `wrap`, based on a construction by @fizruk. + +4.0 +--- +* Updated to work with `semigroupoids` and `comonad` 4.0 +* `instance ComonadCofree Maybe NonEmpty` +* `instance ComonadCofree (Const b) ((,) b)` + +3.4.2 +----- +* Generalized `liftF`. +* 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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,15 +1,15 @@ -free -==== - -[![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://github.com/ekmett/free/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/free/actions?query=workflow%3AHaskell-CI) - -This package provides a common definitions for working with free monads, free applicatives, and cofree comonads in Haskell. - -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 +==== + +[![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://github.com/ekmett/free/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/free/actions?query=workflow%3AHaskell-CI) + +This package provides a common definitions for working with free monads, free applicatives, and cofree comonads in Haskell. + +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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md --- a/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md +++ b/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md @@ -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. diff --git a/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md --- a/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md +++ b/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md @@ -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. diff --git a/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md b/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md --- a/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md +++ b/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md @@ -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`. diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md @@ -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 - ≡ function application -. ≡ (.) -``` - -By repeatedly applying the Applicative laws for the underlying functor, we -get: - -```haskell - -pW <*> (pV <*> (pU <*> p! <*> u) <*> v ) <*> w == - -pW <*> (pV <*> (p(U!) <*> u) <*> v ) <*> w == - -pW <*> (p. <*> pV <*> p(U!) <*> u <*> v ) <*> w == - -pW <*> ( p(.V)(U!) <*> u <*> v ) <*> w == - -p. <*> pW <*> ( p(.V)(U!) <*> u ) <*> v <*> w == - -p(.W) <*> (p(.V)(U!) <*> u) <*> v <*> w == - -p. <*> p(.W) <*> p(.V)(U!) <*> u <*> v <*> w == - -p.(.W)((.V)(U!)) <*> u <*> v <*> w - -``` - -Undoing the shorthand notation and simplifying: - -```haskell - -! == (.) :< empty -U! == \(a :< m) -> (. a) :< fmap (fmap (.)) m -V == \(f :< t) -> \(b :< n) -> (f b) :< (fmap (fmap f) n <|> - fmap (<*> C v) t) - - -. V (U!) == \(a :< m) -> V ((. a) :< fmap (fmap (.)) m) == - == \(a :< m) -> \(b :< n) -> - (a . b) :< (fmap (fmap (. a) n) <|> - fmap (<*> C v) ( fmap (fmap (.)) m) - -W == \(f :< t) -> \(c :< p) -> - (f c) :< (fmap (fmap f) p <|> fmap (<*> C w) t) - -.W == \g -> (\x -> W (g x)) - - - .(.W)(.V(U!)) - -== \s -> (.W)((.V(U!)) s) == - -== \a :< m -> (.W) ((.V(U!)) a :< m) == - -== \a :< m -> (.W) (\(b :< n) -> - (a . b) :< (fmap (fmap (. a) n) <|> - fmap (<*> C v) ( fmap (fmap (.)) m))) == - -== \a :< m -> \b :< n -> - W ( (a . b) :< (fmap (fmap (. a) n) <|> - fmap (<*> C v) ( fmap (fmap (.)) m))) == - -== \a :< m -> \b :< n -> c :< p -> - (a (b c)) :< (fmap (fmap (a . b)) p <|> - fmap (<*> C w) - ((fmap (fmap (. a) n) <|> - fmap (<*> C v) (fmap (fmap (.)) m)))) == - -== \a :< m -> \b :< n -> c :< p -> - (a (b c)) :< (fmap (fmap (a . b)) p <|> - fmap (<*> C w) (fmap (fmap (. a)) n) <|> - fmap (<*> C w) (fmap (<*> C v) ( fmap (fmap (.)) m))) == - -== \a :< m -> \b :< n -> c :< p -> - (a (b c)) :< (fmap (fmap (a . b)) p <|> - fmap (\x -> pure (.) <*> pure a <*> x <*> C w) n) <|> - fmap (\x -> pure (.) <*> x <*> C v <*> C w) m))) -``` - -### Lemma 2 - -We use the following shorthands to make reasoning more readable. - -``` -W ≡ star(C w) -Y ≡ star(C v <*> C w) -p ≡ pure - ≡ function application -. ≡ (.) -$W ≡ ($ star(C w)) -``` - -By repeatedly applying composition law for w, we get: - -```haskell - -pY <*> u <*> (pW <*> v <*> w) == - -p. <*> (pY <*> u) <*> (pW <*> v) <*> w == - -p. <*> p. <*> pY <*> u <*> (pW <*> v) <*> w == - -p. <*> (p. <*> p. <*> pY <*> u) <*> pW <*> v <*> w == - -p. <*> (p..Y <*> u) <*> pW <*> v <*> w == - -p. <*> p. <*> p..Y <*> u <*> pW <*> v <*> w == - -p..(..Y) <*> u <*> pW <*> v <*> w == - -p($W) <*> (p..(..Y) <*> u) <*> v <*> w == - -p.($W)(..(..Y)) <*> u <*> v <*> w - - -(.) == \f -> \g -> \x -> f (g x) - -($W) == \g -> g W - -($W) . (..(..Y)) == \s -> (\g -> g W) ((..(..Y)) s) - == \s -> (..(..Y)) s W - -(. . (..Y)) == (\s -> . ((..Y) s)) - -∴ ($W) . (..(..Y)) == \s -> ((..Y) s) . W - -(..Y) == (\y -> (.) (Y y)) - -∴ ($W) . (..(..Y)) == \s -> ((.) (Y s)) . W - - == \s -> \t -> ((.) (Y s)) (W t) - - == \s -> \t -> (Y s) . (W t) - - == \s -> \t -> u -> (Y s (W t u)) -``` - -Undoing shorthands and α-converting, we get: - -```haskell -.($W)(..(..Y)) == - -\a :< m -> b :< n -> c :< p -> (Y (a :< m) (W (b : b :< n -> c :< p -> - (Y (a :< m) (b c :< (fmap (fmap b) p) <|> - (fmap (<*> C w) n))) == - -\a :< m -> b :< n -> c :< p -> - (Y (a :< m) (b c :< (fmap (fmap b) p) <|> - (fmap (<*> C w) n))) == - -\a :< m -> b :< n -> c :< p -> - (a (b c) :< (fmap (fmap a) ((fmap (fmap b) p) <|> - (fmap (<*> C w) n))) - <|> - (fmap (<*> (C v <*> C w)) m)) - -== {- fmap distributes over <|>, fmap respects composition -} - -\a :< m -> b :< n -> c :< p -> - (a (b c) :< (fmap (fmap (a . b)) p) <|> - (fmap ((fmap a) . (<*> C w)) n) <|> - (fmap (<*> (C v <*> C w)) m)) - -== - -\a :< m -> b :< n -> c :< p -> - (a (b c) :< (fmap (fmap (a . b)) p) <|> - (fmap (\x -> pure a <*> (x <*> C w)) n) <|> - (fmap (\x -> x<*> (C v <*> C w)) m) ) -``` - -## Homomorphism - -```haskell - - pure f <*> pure x - -== {- definition of <*> -} - - C $ - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> pure x) t)) <$> - pure (f :< empty) <*> pure (x :< empty) - -== {- homomorphism law for w, twice -} - - C $ pure $ - let (b :< n) = bimap f (fmap f) (x :< empty) in - b :< (n <|> fmap (<*> pure x) empty)) - -== {- bimap -} - - C $ pure $ - let (b :< n) = (f x :< (fmap f empty)) in - b :< (n <|> fmap (<*> pure x) empty)) - -== {- empty invariant under fmap -} - - C $ pure $ (f x) :< (empty <|> empty) - -== {- definition -} - - pure (f x) - -``` - -## Interchange - -```haskell - - u <*> pure y - -== {- definition of <*>, pure -} - - C $ - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> (pure y)) t)) <$> u <*> (pure (y :< empty)) - -== {- interchange law for w -} - - C $ - pure ($ y :< empty) <*> - (pure - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> (pure y)) t))) <*> u) - -== {- composition -} - - C $ - pure (.) <*> - pure ($ y :< empty) <*> - pure - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> (pure y)) t)) - - <*> u) - -== {- homomorphism -} - - C $ - pure (($ y :< empty) .) <*> - pure - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> (pure y)) t)) - - <*> u) - -== {- homomorphism -} - - C $ - pure (($ y :< empty) . - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> (pure y)) t)) - <*> u) - -== {- β-reduction -} - - C $ - pure ( - ( \(f :< t) -> - let (b :< n) = bimap f (fmap f) (y :< empty) in - b :< (n <|> fmap (<*> (pure y)) t)) - <*> u) - -== {- bimap, β-reduction -} - - C $ - pure ( - ( \(f :< t) -> f y :< (empty <|> fmap (<*> (pure y)) t)) - <*> u) - -== {- fmap -} - - C $ (\(f :< t) -> f y :< (fmap (<*> pure y) t)) <$> u - -== {- coinduction (consume 1, produce 1) -} - - C $ (\(f :< t) -> f y :< (fmap ($ y) t)) <$> u - -== {- def. $ -} - - C $ (\(f :< t) -> ($ y) f :< (fmap ($ y) t)) <$> u - -== {- def. bimap -} - - C $ bimap ($ y) (fmap ($ y)) <$> u - -== {- β,η-expansion -} - - C $ - ( - \(a) -> - let (b :< n) = bimap ($ y) (fmap ($ y)) a in - b :< n) <$> u - -== {- empty inviariant under fmap -} - - C $ - ( - \(a) -> - let (b :< n) = bimap ($ y) (fmap ($ y)) a in - b :< (n <|> fmap (<*> u) empty)) <$> u - -== {- fmap over pure -} - - C $ - ( \(f :< t) -> - \(a) -> - let (b :< n) = bimap f (fmap f) a in - b :< (n <|> fmap (<*> u) t)) <$> (pure (($ y) :< empty)) <*> u - -== {- definition -} - -pure ($ y) <*> u -``` - -## Consistency with Monad definition - -```haskell -instance (Alternative f, Monad w) => Monad (CofreeT f w) where - return = CofreeT . return . (:< empty) - (CofreeT cx) >>= f = CofreeT $ do - (a :< m) <- cx - (b :< n) <- runCofreeT $ f a - return $ b :< (n <|> fmap (>>= f) m) -``` - -If w is also a monad, then ```(<*>) == ap```. - -The proof uses coinduction for the case “produce one, consume one”. - -_Remark:_ If ```g = (\f -> (CofreeT wa) >>= (\a -> return $ f a))```, then - ```(`ap` a) == (>>= g)```. - -```haskell - -(C wf) `ap` (C wa) - -== {- definition -} - -(C wf) >>= (\f -> (C wa) >>= (\a -> f a)) - -== {- definition -} - - wf >>= \(f :< t) -> - unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> - return $ b :< (n <|> fmap (>>= g) t) - -== {- coinductive step -} - - wf >>= \(f :< t) -> - unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> - return $ b :< (n <|> fmap (<*> C wa) t) -== {- definition of fmap for monads -} - - - wf >>= \(f :< t) -> - unC (fmap f (C wa)) >>= \(b :< n) -> - return $ b :< (n <|> fmap (<*> C wa) t) - -== {- definition of fmap for C -} - - wf >>= \(f :< t) -> - fmap (bimap f (fmap f)) wa >>= \(b :< n) -> - return $ b :< (n <|> fmap (<*> C wa) t) - -== {- definition of fmap for monads -} - - wf >>= \(f :< t) -> - (wa >>= (\a -> return (bimap f (fmap f) a) >>= \(b :< n) -> - return $ b :< (n <|> fmap (<*> C wa) t) - -== {- associativity of monads -} - - wf >>= \(f :< t) -> - wa >>= \a -> - (return (bimap f (fmap f a))) >>= \(b :< n) -> - return $ b :< (n <|> fmap (<*> a) m) - -== {- Left identity of monads -} - - wf >>= \(f :< t) -> - wa >>= \(a -> - let b :< n = bimap f (fmap f a)) in - return $ b :< (n <|> fmap (<*> a) m)) - -== {- Equivalence of (>>=) and (<*>) for monad w. -} - - \(f :< t) -> - \(a -> - let b :< n = bimap f (fmap f a)) in - return $ b :< (n <|> fmap (<*> a) m))) - -== {- definition of (<*>) -} - -(CofreeT wf) <*> (CofreeT wa) - -``` - - +Applicative instance for CofreeT +================================ + +If the underlying functor f is an instance of Alternative, then CofreeT is also +an applicative functor. + +Note that the only required properties of Alternative are associativity and +existence of an identity element, so one could also use functors that are +instances of Plus (semigroupoid package). + +```haskell +instance (Alternative f, Applicative w) => + Applicative (CofreeT f w) where + pure = CofreeT . pure . (:< empty) + + (CofreeT wf) <*> aa@(CofreeT wa) = CofreeT $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> aa) t)) <$> wf <*> wa +``` + + +## Identity + +```haskell + + pure id <*> (C wa) + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> C wa) t)) <$> (pure $ id :< empty) <*> wa + +== {- w is Applicative -} + + C $ + \(a) -> + let (b :< n) = bimap id (fmap id) a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- functor preserves identity -} + + C $ + \(a) -> + let (b :< n) = bimap id id a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- bifunctors preserve identity -} + + C $ + \(a) -> + let (b :< n) = a in + b :< (n <|> fmap (<*> C wa) empty)) <$> wa + +== {- empty is invariant under fmap -} + + C $ + \(a) -> + let (b :< n) = a in + b :< (n <|> empty) <$> wa + +== {- empty is identity, β-reduction -} + + C $ id <$> wa + +== {- functor preserves identity -} + + C wa + +``` + + +## Composition + +First, we rewrite the definition of the (<*>) into something simpler: + +```haskell + + (C wf) <*> (C wa) + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- pattern match on CofreeF -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + let (b :< n) = bimap f (fmap f) (a :< m) in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- definition of bimap -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + let (b :< n) = f a :< fmap (fmap f) m in + b :< (n <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- β-equivalence -} + + C $ + ( \(f :< t) -> + \(a :< m) -> + (f a) :< (fmap (fmap f) m <|> fmap (<*> C wa) t)) <$> wf <*> wa + +== {- define star(C wa) ≡ ( \(f :< t) -> … (<*> C wa) … ) -} + + C $ star(C wa) <$> wf <*> wa + +== {- fmap for w Applicative -} + + C (pure star(C wa) <*> wf <*> wa) + +``` + +Now, we can prove the law of composition: + +```haskell + + pure (.) <*> C u <*> C v <*> C w + +== {- definition of <*> -} + + C (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> C v <*> C w + +== {- definition of <*> -} + + C (pure star(C v) <*> + (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> + v + ) <*> + C w + +== {- definition of <*> -} + + C (pure star(C w) <*> + (pure star(C v) <*> + (pure star(C u) <*> pure ((.) :< empty) <*> u ) <*> + v) <*> + w) + + +== {- see lemma 1 -} + + C $ (\a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (\x -> pure (.) <*> pure a <*> x <*> C w) n) <|> + fmap (\x -> pure (.) <*> x <*> C v <*> C w) m))) == + + + + +== {- coinduction on recursive definition (“produce 1, consume 1”) -} + + + C $ (\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap (\x -> pure a <*> (x <*> C w)) n) <|> + (fmap (\x -> x<*> (C v <*> C w)) m) ) + + +== {- see lemma 2 -} + + C (pure star(C v <*> C w) <*> + u <*> + (pure star(C w) <*> + v <*> + w)) + +== {- definition of <*> -} + + C (pure star(C v <*> C w) <*> u <*> unC (C v <*> C w)) + +== {- definition of <*> -} + + C u <*> (C v <*> C w) +``` + +### Lemma 1 + +To make reasoning easier, we'll use a shortand notation. + +``` +U ≡ star(C v) +V ≡ star(C u) +W ≡ star(C w) +! ≡ (.) :< empty +p ≡ pure + ≡ function application +. ≡ (.) +``` + +By repeatedly applying the Applicative laws for the underlying functor, we +get: + +```haskell + +pW <*> (pV <*> (pU <*> p! <*> u) <*> v ) <*> w == + +pW <*> (pV <*> (p(U!) <*> u) <*> v ) <*> w == + +pW <*> (p. <*> pV <*> p(U!) <*> u <*> v ) <*> w == + +pW <*> ( p(.V)(U!) <*> u <*> v ) <*> w == + +p. <*> pW <*> ( p(.V)(U!) <*> u ) <*> v <*> w == + +p(.W) <*> (p(.V)(U!) <*> u) <*> v <*> w == + +p. <*> p(.W) <*> p(.V)(U!) <*> u <*> v <*> w == + +p.(.W)((.V)(U!)) <*> u <*> v <*> w + +``` + +Undoing the shorthand notation and simplifying: + +```haskell + +! == (.) :< empty +U! == \(a :< m) -> (. a) :< fmap (fmap (.)) m +V == \(f :< t) -> \(b :< n) -> (f b) :< (fmap (fmap f) n <|> + fmap (<*> C v) t) + + +. V (U!) == \(a :< m) -> V ((. a) :< fmap (fmap (.)) m) == + == \(a :< m) -> \(b :< n) -> + (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m) + +W == \(f :< t) -> \(c :< p) -> + (f c) :< (fmap (fmap f) p <|> fmap (<*> C w) t) + +.W == \g -> (\x -> W (g x)) + + + .(.W)(.V(U!)) + +== \s -> (.W)((.V(U!)) s) == + +== \a :< m -> (.W) ((.V(U!)) a :< m) == + +== \a :< m -> (.W) (\(b :< n) -> + (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> + W ( (a . b) :< (fmap (fmap (. a) n) <|> + fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (<*> C w) + ((fmap (fmap (. a) n) <|> + fmap (<*> C v) (fmap (fmap (.)) m)))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (<*> C w) (fmap (fmap (. a)) n) <|> + fmap (<*> C w) (fmap (<*> C v) ( fmap (fmap (.)) m))) == + +== \a :< m -> \b :< n -> c :< p -> + (a (b c)) :< (fmap (fmap (a . b)) p <|> + fmap (\x -> pure (.) <*> pure a <*> x <*> C w) n) <|> + fmap (\x -> pure (.) <*> x <*> C v <*> C w) m))) +``` + +### Lemma 2 + +We use the following shorthands to make reasoning more readable. + +``` +W ≡ star(C w) +Y ≡ star(C v <*> C w) +p ≡ pure + ≡ function application +. ≡ (.) +$W ≡ ($ star(C w)) +``` + +By repeatedly applying composition law for w, we get: + +```haskell + +pY <*> u <*> (pW <*> v <*> w) == + +p. <*> (pY <*> u) <*> (pW <*> v) <*> w == + +p. <*> p. <*> pY <*> u <*> (pW <*> v) <*> w == + +p. <*> (p. <*> p. <*> pY <*> u) <*> pW <*> v <*> w == + +p. <*> (p..Y <*> u) <*> pW <*> v <*> w == + +p. <*> p. <*> p..Y <*> u <*> pW <*> v <*> w == + +p..(..Y) <*> u <*> pW <*> v <*> w == + +p($W) <*> (p..(..Y) <*> u) <*> v <*> w == + +p.($W)(..(..Y)) <*> u <*> v <*> w + + +(.) == \f -> \g -> \x -> f (g x) + +($W) == \g -> g W + +($W) . (..(..Y)) == \s -> (\g -> g W) ((..(..Y)) s) + == \s -> (..(..Y)) s W + +(. . (..Y)) == (\s -> . ((..Y) s)) + +∴ ($W) . (..(..Y)) == \s -> ((..Y) s) . W + +(..Y) == (\y -> (.) (Y y)) + +∴ ($W) . (..(..Y)) == \s -> ((.) (Y s)) . W + + == \s -> \t -> ((.) (Y s)) (W t) + + == \s -> \t -> (Y s) . (W t) + + == \s -> \t -> u -> (Y s (W t u)) +``` + +Undoing shorthands and α-converting, we get: + +```haskell +.($W)(..(..Y)) == + +\a :< m -> b :< n -> c :< p -> (Y (a :< m) (W (b : b :< n -> c :< p -> + (Y (a :< m) (b c :< (fmap (fmap b) p) <|> + (fmap (<*> C w) n))) == + +\a :< m -> b :< n -> c :< p -> + (Y (a :< m) (b c :< (fmap (fmap b) p) <|> + (fmap (<*> C w) n))) == + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap a) ((fmap (fmap b) p) <|> + (fmap (<*> C w) n))) + <|> + (fmap (<*> (C v <*> C w)) m)) + +== {- fmap distributes over <|>, fmap respects composition -} + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap ((fmap a) . (<*> C w)) n) <|> + (fmap (<*> (C v <*> C w)) m)) + +== + +\a :< m -> b :< n -> c :< p -> + (a (b c) :< (fmap (fmap (a . b)) p) <|> + (fmap (\x -> pure a <*> (x <*> C w)) n) <|> + (fmap (\x -> x<*> (C v <*> C w)) m) ) +``` + +## Homomorphism + +```haskell + + pure f <*> pure x + +== {- definition of <*> -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> pure x) t)) <$> + pure (f :< empty) <*> pure (x :< empty) + +== {- homomorphism law for w, twice -} + + C $ pure $ + let (b :< n) = bimap f (fmap f) (x :< empty) in + b :< (n <|> fmap (<*> pure x) empty)) + +== {- bimap -} + + C $ pure $ + let (b :< n) = (f x :< (fmap f empty)) in + b :< (n <|> fmap (<*> pure x) empty)) + +== {- empty invariant under fmap -} + + C $ pure $ (f x) :< (empty <|> empty) + +== {- definition -} + + pure (f x) + +``` + +## Interchange + +```haskell + + u <*> pure y + +== {- definition of <*>, pure -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) <$> u <*> (pure (y :< empty)) + +== {- interchange law for w -} + + C $ + pure ($ y :< empty) <*> + (pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t))) <*> u) + +== {- composition -} + + C $ + pure (.) <*> + pure ($ y :< empty) <*> + pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + + <*> u) + +== {- homomorphism -} + + C $ + pure (($ y :< empty) .) <*> + pure + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + + <*> u) + +== {- homomorphism -} + + C $ + pure (($ y :< empty) . + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- β-reduction -} + + C $ + pure ( + ( \(f :< t) -> + let (b :< n) = bimap f (fmap f) (y :< empty) in + b :< (n <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- bimap, β-reduction -} + + C $ + pure ( + ( \(f :< t) -> f y :< (empty <|> fmap (<*> (pure y)) t)) + <*> u) + +== {- fmap -} + + C $ (\(f :< t) -> f y :< (fmap (<*> pure y) t)) <$> u + +== {- coinduction (consume 1, produce 1) -} + + C $ (\(f :< t) -> f y :< (fmap ($ y) t)) <$> u + +== {- def. $ -} + + C $ (\(f :< t) -> ($ y) f :< (fmap ($ y) t)) <$> u + +== {- def. bimap -} + + C $ bimap ($ y) (fmap ($ y)) <$> u + +== {- β,η-expansion -} + + C $ + ( + \(a) -> + let (b :< n) = bimap ($ y) (fmap ($ y)) a in + b :< n) <$> u + +== {- empty inviariant under fmap -} + + C $ + ( + \(a) -> + let (b :< n) = bimap ($ y) (fmap ($ y)) a in + b :< (n <|> fmap (<*> u) empty)) <$> u + +== {- fmap over pure -} + + C $ + ( \(f :< t) -> + \(a) -> + let (b :< n) = bimap f (fmap f) a in + b :< (n <|> fmap (<*> u) t)) <$> (pure (($ y) :< empty)) <*> u + +== {- definition -} + +pure ($ y) <*> u +``` + +## Consistency with Monad definition + +```haskell +instance (Alternative f, Monad w) => Monad (CofreeT f w) where + return = CofreeT . return . (:< empty) + (CofreeT cx) >>= f = CofreeT $ do + (a :< m) <- cx + (b :< n) <- runCofreeT $ f a + return $ b :< (n <|> fmap (>>= f) m) +``` + +If w is also a monad, then ```(<*>) == ap```. + +The proof uses coinduction for the case “produce one, consume one”. + +_Remark:_ If ```g = (\f -> (CofreeT wa) >>= (\a -> return $ f a))```, then + ```(`ap` a) == (>>= g)```. + +```haskell + +(C wf) `ap` (C wa) + +== {- definition -} + +(C wf) >>= (\f -> (C wa) >>= (\a -> f a)) + +== {- definition -} + + wf >>= \(f :< t) -> + unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (>>= g) t) + +== {- coinductive step -} + + wf >>= \(f :< t) -> + unC (C wa >>= (\a -> return $ f a)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) +== {- definition of fmap for monads -} + + + wf >>= \(f :< t) -> + unC (fmap f (C wa)) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- definition of fmap for C -} + + wf >>= \(f :< t) -> + fmap (bimap f (fmap f)) wa >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- definition of fmap for monads -} + + wf >>= \(f :< t) -> + (wa >>= (\a -> return (bimap f (fmap f) a) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> C wa) t) + +== {- associativity of monads -} + + wf >>= \(f :< t) -> + wa >>= \a -> + (return (bimap f (fmap f a))) >>= \(b :< n) -> + return $ b :< (n <|> fmap (<*> a) m) + +== {- Left identity of monads -} + + wf >>= \(f :< t) -> + wa >>= \(a -> + let b :< n = bimap f (fmap f a)) in + return $ b :< (n <|> fmap (<*> a) m)) + +== {- Equivalence of (>>=) and (<*>) for monad w. -} + + \(f :< t) -> + \(a -> + let b :< n = bimap f (fmap f a)) in + return $ b :< (n <|> fmap (<*> a) m))) + +== {- definition of (<*>) -} + +(CofreeT wf) <*> (CofreeT wa) + +``` + + diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md @@ -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). diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md @@ -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) +``` + + + + diff --git a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md --- a/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md +++ b/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md @@ -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) + +. +``` diff --git a/examples/Cabbage.lhs b/examples/Cabbage.lhs --- a/examples/Cabbage.lhs +++ b/examples/Cabbage.lhs @@ -1,209 +1,207 @@ -> {-# LANGUAGE ViewPatterns #-} -> module Cabbage where - -> import Control.Monad -> import Control.Monad.State -> import Control.Monad.Trans.Iter -> import Control.Monad.Writer -> import Data.Functor.Identity -> import Data.Maybe -> import Data.Tuple -> import Data.List (inits, tails) -> 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) + +Consider the following problem: + +A farmer must cross a river with a wolf, a sheep and a cabbage. +He owns a boat, which can only carry himself and one other item. +The sheep must not be left alone with the wolf, or with the cabbage: +if that happened, one of them would eat the other. + +> data Item = Wolf | Sheep | Cabbage | Farmer deriving (Ord, Show, Eq) +> +> eats :: Item -> Item -> Bool +> Sheep `eats` Cabbage = True +> Wolf `eats` Sheep = True +> _ `eats` _ = False + +The problem can be represented as the set of items on each side of the river. + +> type Situation = ([Item],[Item]) + +> initial :: Situation +> initial = ([Farmer, Wolf, Sheep, Cabbage], []) + +First, some helper functions to extract single elements from lists, leaving the +rest intact: + +> plusTailOf :: [a] -> [a] -> (Maybe a, [a]) +> a `plusTailOf` b = (listToMaybe b, a ++ drop 1 b) + +> singleOut1 :: (a -> Bool) -> [a] -> (Maybe a,[a]) +> singleOut1 sel = uncurry plusTailOf . break sel + +@ +*Cabbage> singleOut1 (== Sheep) [Wolf, Sheep, Cabbage] +(Just Sheep,[Wolf,Cabbage]) +@ + +> singleOutAll :: [a] -> [(Maybe a,[a])] +> singleOutAll = zipWith plusTailOf <$> inits <*> tails + +@ +*Cabbage> singleOutAll [Wolf, Sheep, Cabbage] +[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])] +@ + +In every move, the farmer goes from one side of the river to the other, +together with (optionally) one item. + +The remaining items must not eat each other for the move to be valid. + +> move :: Situation -> [Situation] +> move = move2 +> where +> move2 (singleOut1 (== Farmer) -> (Just Farmer,as), bs) = move1 as bs +> move2 (bs, singleOut1 (== Farmer) -> (Just Farmer,as)) = map swap $ move1 as bs +> move2 _ = [] +> +> move1 as bs = [(as', [Farmer] ++ maybeToList b ++ bs) | +> (b, as') <- singleOutAll as, +> and [not $ x `eats` y | x <- as', y <- as']] + +@ +*Cabbage> move initial +[([Wolf,Cabbage],[Farmer,Sheep])] +@ + +When the starting side becomes empty, the farmer succeeds. + +> success :: Situation -> Bool +> success ([],_) = True +> success _ = False + +A straightforward implementation to solve the problem could use the +list monad, trying all possible solutions and + +> solution1 :: Situation +> solution1 = head $ solutions' initial +> where +> solutions' a = if success a +> then return a +> else move a >>= solutions' + +However, when it's run, it will get stuck in an infinite loop, as the sheep +is shuffled back and forth. The solution is being searched in depth. + +To guarantee termination, we can use the 'Iter' monad with its MonadPlus instance. +As long as one of the possible execution paths finds a solution, the program +will terminate: the solution is looked for _in breadth_. + +> solution2 :: Iter Situation +> solution2 = solution' initial +> where +> solution' a = +> if success a +> then return a +> else delay $ msum $ map solution' (move a) + +Each of the alternative sequences of movements will be evaluated +concurrently; and the shortest one will be the result. In case of ties, +the leftmost solution takes priority. + +@ + *Cabbage> solution2 + IterT (Identity (Right ( … + (IterT (Identity (Right + (IterT (Identity (Left + ([],[Farmer,Sheep,Cabbage,Wolf])))))))))))))))))))))))) +@ + +For a cleaner display, use 'retract' to escape 'Iter' monad: + +@ + *Cabbage> retract solution2 + Identity ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +'unsafeIter' will also get rid of the 'Identity' wrapper: + +> unsafeIter :: Iter a -> a +> unsafeIter = runIdentity . retract + +@ + *Cabbage> unsafeIter solution2 + ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +Suppose that we not only want the solution, but also the steps that we +took to arrive there. Enter the Writer monad transformer: + +> solution3 :: Iter (Situation, [Situation]) +> solution3 = runWriterT $ solution' initial +> where +> solution' :: Situation -> WriterT [Situation] Iter Situation +> solution' a = do +> tell [a] +> if success a +> then return a +> else mapWriterT delay $ msum $ map solution' (move a) + +The second component contains the complete path to the solution: + +@ + *Cabbage> snd $ unsafeIter solution3 + [([Farmer,Wolf,Sheep,Cabbage],[]), + ([Wolf,Cabbage],[Farmer,Sheep]), + ([Farmer,Wolf,Cabbage],[Sheep]), + ([Cabbage],[Farmer,Wolf,Sheep]), + ([Farmer,Sheep,Cabbage],[Wolf]), + ([Sheep],[Farmer,Cabbage,Wolf]), + ([Farmer,Sheep],[Cabbage,Wolf]), + ([],[Farmer,Sheep,Cabbage,Wolf])] +@ + +When the transformer is applied _over_ the Iter monad, it acts locally for each solution. +If we apply the IterT transformer over another monad, +the behaviour for that monad will be shared among all threads. + +For example, let's keep track of how many moves we perform. We could +do so with the writer monad again (numbers form a monoid under addition), but +we'll use the state monad this time. + +> solution4 :: Iter (Situation, Integer) +> solution4 = flip runStateT 0 $ solution' initial +> where +> solution' :: Situation -> StateT Integer Iter Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> mapStateT delay $ msum $ map solution' (move a) + +This gives us seven moves (one for each transition between two states). + +@ + *Cabbage> unsafeIter solution4 + (([],[Farmer,Sheep,Cabbage,Wolf]),7) +@ + +On the other hand, if move the state inside Iter, we get a global count of +explored nodes until the solution was found. + +> solution5 :: State Integer Situation +> solution5 = retract $ solution' initial +> where +> solution' :: Situation -> IterT (State Integer) Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> delay $ msum $ map solution' (move a) + +@ + *Cabbage> runState solution5 0 + (([],[Farmer,Sheep,Cabbage,Wolf]),113) +@ diff --git a/examples/LICENSE b/examples/LICENSE --- a/examples/LICENSE +++ b/examples/LICENSE @@ -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. diff --git a/examples/MandelbrotIter.lhs b/examples/MandelbrotIter.lhs --- a/examples/MandelbrotIter.lhs +++ b/examples/MandelbrotIter.lhs @@ -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 , -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 , +the following sequence is generated for each point @c@ in the complex plane: + +@ +z₀ = c + +z₁ = z₀² + c + +z₂ = z₁² + c + +… +@ + +If, after some iterations, |z_i| ≥ 2, the point is not in the set. We +can compute if a point is not in the Mandelbrot set this way: + +@ + escaped :: Complex Double -> Int + escaped c = loop 0 0 where + loop z n = if (magnitude z) >= 2 then n + else loop (z*z + c) (n+1) +@ + +If @c@ is not in the Mandelbrot set, we get the number of iterations required to +prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will +run forever. + +We can use the 'Iter' monad to delimit this effect. By applying +'delay' before the recursive call, we decompose the computation into +terminating steps. + +> escaped :: Complex Double -> Iter Int +> escaped c = loop 0 0 where +> loop z n = if (magnitude z) >= 2 then return n +> else delay $ loop (z*z + c) (n+1) +> + +If we draw each point on a canvas after it escapes, we can get a _negative_ +image of the Mandelbrot set. Drawing pixels is a side-effect, so it +should happen inside the IO monad. Also, we want to have an +environment to store the size of the canvas, and the target window. + +By using 'IterT', we can add all these behaviours to our non-terminating +computation. + +> data Canvas = Canvas { width :: Int, height :: Int, window :: Window } +> +> type FractalM a = IterT (ReaderT Canvas IO) a + +Any simple, non-terminating computation can be lifted into a richer environment. + +> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int +> escaped' = liftIter . escaped + +Then, to draw a point, we can just retrieve the number of iterations until it +finishes, and draw it. The color will depend on the number of iterations. + +> mandelbrotPoint :: (Int, Int) -> FractalM () +> mandelbrotPoint p = do +> c <- scale p +> n <- escaped' c +> let color = if (even n) then RGB 0 0 255 -- Blue +> else RGB 0 0 127 -- Darker blue +> drawPoint color p + +The pixels on the screen don't match the region in the complex plane where the +fractal is; we need to map them first. The region we are interested in is +Im z = [-1,1], Re z = [-2,1]. + +> scale :: (Int, Int) -> FractalM (Complex Double) +> scale (xi,yi) = do +> (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height) +> let (x,y) = (fromIntegral xi, fromIntegral yi) +> let im = (-y + h / 2 ) / (h/2) +> let re = ( x - w * 2 / 3 ) / (h/2) +> return $ re :+ im + +Drawing a point is equivalent to drawing a line of length one. + +> drawPoint :: RGB -> (Int,Int) -> FractalM () +> drawPoint color (x,y) = do +> w <- asks window +> let point = line (x,y) (x+1, y+1) +> liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point) + +We may want to draw more than one point. However, if we just sequence the computations +monadically, the first point that is not a member of the set will block the whole +process. We need advance all the points at the same pace, by interleaving the +computations. + +> drawMandelbrot :: FractalM () +> drawMandelbrot = do +> (w,h) <- asks $ width &&& height +> let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]] +> interleave_ ps + +To run this computation, we can just use @retract@, which will run indefinitely: + +> runFractalM :: Canvas -> FractalM a -> IO a +> runFractalM canvas = flip runReaderT canvas . retract + +Or, we can trade non-termination for getting an incomplete result, +by cutting off after a certain number of steps. + +> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a) +> runFractalM' n canvas = flip runReaderT canvas . retract . cutoff n + +Thanks to the 'IterT' transformer, we can separate timeout concerns from +computational concerns. + +> main :: IO () +> main = do +> let windowWidth = 800 +> let windowHeight = 480 +> runGraphics $ do +> w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1) +> let canvas = Canvas windowWidth windowHeight w +> _ <- runFractalM' 100 canvas drawMandelbrot +> putStrLn $ "Fin" + diff --git a/examples/NewtonCoiter.lhs b/examples/NewtonCoiter.lhs --- a/examples/NewtonCoiter.lhs +++ b/examples/NewtonCoiter.lhs @@ -1,102 +1,100 @@ -Many numerical approximation methods compute infinite sequences of results; each, -hopefully, more accurate than the previous one. - - -to find zeroes of a function is one such algorithm. - -> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} -> module Main where - -> import Control.Comonad.Trans.Coiter -> import Control.Comonad.Env -> import Data.Foldable (toList, find) -> 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. + + +to find zeroes of a function is one such algorithm. + +> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} +> module Main where + +> import Control.Comonad.Trans.Coiter +> import Control.Comonad.Env +> import Data.Foldable (toList, find) + +> data Function = Function { +> -- Function to find zeroes of +> function :: Double -> Double, +> -- Derivative of the function +> derivative :: Double -> Double +> } +> +> data Result = Result { +> -- Estimated zero of the function +> value :: Double, +> -- Estimated distance to the actual zero +> xerror :: Double, +> -- How far is value from being an actual zero; that is, +> -- the difference between @0@ and @f value@ +> ferror :: Double +> } deriving (Show) +> +> data Outlook = Outlook { result :: Result, +> -- Whether the result improves in future steps +> progress :: Bool } deriving (Show) + +To make our lives easier, we will store the problem at hand using the Env +environment comonad. + +> type Solution a = CoiterT (Env Function) a + +Problems consist of a function and its derivative as the environment, and +an initial value. + +> type Problem = Env Function Double + +We can express an iterative algorithm using unfold over an initial environment. + +> newton :: Problem -> Solution Double +> newton = unfold (\wd -> +> let f = asks function wd in +> let df = asks derivative wd in +> let x = extract wd in +> x - f x / df x) +> +> + +To estimate the error, we look forward one position in the stream. The next value +will be much more precise than the current one, so we can consider it as the +actual result. + +We know that the exact value of a function at one of it's zeroes is 0. So, +@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@ + +> estimateError :: Solution Double -> Result +> estimateError s = +> let (a, s') = extract $ runCoiterT s in +> let a' = extract s' in +> let f = asks function s in +> Result { value = a, +> xerror = abs $ a - a', +> ferror = abs $ f a +> } + +To get a sense of when the algorithm is making any progress, we can sample the +future and check if the result improves at all. + +> estimateOutlook :: Int -> Solution Result -> Outlook +> estimateOutlook sampleSize solution = +> let sample = map ferror $ take sampleSize $ tail $ toList solution in +> let result' = extract solution in +> Outlook { result = result', +> progress = ferror result' > minimum sample } + +To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will +stop whenever the accuracy of the result doesn't improve in the next 5 steps. + +The starting value for our algorithm is @c@ itself. One could compute a better +estimate, but the algorithm converges fast enough that it's not really worth it. + +> squareRoot :: Double -> Maybe Result +> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c), +> derivative = (\x -> 2*x) }) +> in +> fmap result $ find (not . progress) $ +> newton problem =>> estimateError =>> estimateOutlook 5 + +This program will output the result together with the error. + +> main :: IO () +> main = putStrLn $ show $ squareRoot 3 + diff --git a/examples/PerfTH.hs b/examples/PerfTH.hs --- a/examples/PerfTH.hs +++ b/examples/PerfTH.hs @@ -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" + diff --git a/examples/RetryTH.hs b/examples/RetryTH.hs --- a/examples/RetryTH.hs +++ b/examples/RetryTH.hs @@ -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 (readMaybe) + +-- | A data type representing basic commands for a retriable eDSL. +data RetryF next where + Output :: String -> next -> RetryF next + Input :: Read a => (a -> next) -> RetryF next + WithRetry :: Retry a -> (a -> next) -> RetryF next + Retry :: RetryF next + +-- | Unfortunately this Functor instance cannot yet be derived +-- automatically by GHC. +instance Functor RetryF where + fmap f (Output s x) = Output s (f x) + fmap f (Input g) = Input (f . g) + fmap f (WithRetry block g) = WithRetry block (f . g) + fmap _ Retry = Retry + +-- | The monad for a retriable eDSL. +type Retry = Free RetryF + +-- | Simple output command. +makeFreeCon 'Output + +-- | Get anything readable from input. +makeFreeCon 'Input + +-- | Force retry command (retries innermost retriable block). +makeFreeCon 'Retry + +makeFreeCon_ 'WithRetry +-- | Run a retryable block. +withRetry :: MonadFree RetryF m => + Retry a -- ^ Computation to retry. + -> m a -- ^ Computation that retries until succeeds. + +-- The following functions have been made available: +-- +-- output :: MonadFree RetryF m => String -> m () +-- input :: (MonadFree RetryF m, Read a) => m a +-- withRetry :: MonadFree RetryF m => Retry a -> m a +-- retry :: MonadFree RetryF m => m a + +-- | We can run a retriable program in any MonadIO. +runRetry :: (MonadFail m, MonadIO m) => Retry a -> m a +runRetry = iterM run + where + run :: (MonadFail m, MonadIO m) => RetryF (m a) -> m a + + run (Output s next) = do + liftIO $ putStrLn s + next + + run (Input next) = do + s <- liftIO getLine + case readMaybe s of + Just x -> next x + Nothing -> Fail.fail "invalid input" + + run (WithRetry block next) = do + -- Here we use + -- runRetry :: MonadIO m => Retry a -> MaybeT (m a) + -- to control failure with MaybeT. + -- We repeatedly run retriable block until we get it to work. + Just x <- runMaybeT . F.msum $ repeat (runRetry block) + next x + + run Retry = Fail.fail "forced retry" + +-- | Sample program. +test :: Retry () +test = do + n <- withRetry $ do + output "Enter any positive number: " + n <- input + when (n <= 0) $ do + output "The number should be positive." + retry + return n + output $ "You've just entered " ++ show (n :: Int) + +main :: IO () +main = runRetry test diff --git a/examples/Teletype.lhs b/examples/Teletype.lhs --- a/examples/Teletype.lhs +++ b/examples/Teletype.lhs @@ -1,106 +1,104 @@ -> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- -> module Main where - -> import qualified Control.Exception as E (catch) -> import Control.Monad (mfilter) -> import Control.Monad.Loops (unfoldM) -> import Control.Monad.Free (liftF, Free, iterM, MonadFree) -> import Control.Monad.Free.TH (makeFree) -> import 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 System.IO (isEOF) +> import System.IO.Error (ioeGetErrorString) +> import System.Exit (exitSuccess) + +First, we define a data type with the primitive actions of a teleprinter. The +@param@ will stand for the next action to execute. + +> type Error = String +> +> data Teletype param = Halt -- Abort (ignore all following instructions) +> | NL param -- Newline +> | Read (Char -> param) -- Get a character from the terminal +> | ReadOrEOF { onEOF :: param, +> onChar :: Char -> param } -- GetChar if not end of file +> | ReadOrError (Error -> param) +> (Char -> param) -- GetChar with error code +> | param :\^^ String -- Write a message to the terminal +> | (:%) param String [String] -- String interpolation +> deriving (Functor) + +By including a 'makeFree' declaration: + +> makeFree ''Teletype + +the following functions have been made available: + +@ + halt :: (MonadFree Teletype m) => m a + nL :: (MonadFree Teletype m) => m () + read :: (MonadFree Teletype m) => m Char + readOrEOF :: (MonadFree Teletype m) => m (Maybe Char) + readOrError :: (MonadFree Teletype m) => m (Either Error Char) + (\\^^) :: (MonadFree Teletype m) => String -> m () + (%) :: (MonadFree Teletype m) => String -> [String] -> m () +@ + +To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a +'Functor', we can use the one provided in the 'Control.Monad.Free' package. + +> type TeletypeM = Free Teletype + +Programs can be run in different ways. For example, we can use the +system terminal through the @IO@ monad. + +> runTeletypeIO :: TeletypeM a -> IO a +> runTeletypeIO = iterM run where +> run :: Teletype (IO a) -> IO a +> run Halt = do +> putStrLn "This conversation can serve no purpose anymore. Goodbye." +> exitSuccess +> +> run (Read f) = getChar >>= f +> run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof +> else getChar >>= f +> +> run (ReadOrError ferror f) = E.catch (getChar >>= f) (ferror . ioeGetErrorString) +> run (NL rest) = putChar '\n' >> rest +> run (rest :\^^ str) = putStr str >> rest +> run ((:%) rest format tokens) = ttFormat format tokens >> rest +> +> ttFormat :: String -> [String] -> IO () +> ttFormat [] _ = return () +> ttFormat ('\\':'%':cs) tokens = putChar '%' >> ttFormat cs tokens +> ttFormat ('%':cs) (t:tokens) = putStr t >> ttFormat cs tokens +> ttFormat (c:cs) tokens = putChar c >> ttFormat cs tokens + +Now, we can write some helper functions: + +> readLine :: TeletypeM String +> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF + +And use them to interact with the user: + +> hello :: TeletypeM () +> hello = do +> (\^^) "Hello! What's your name?"; nL +> name <- readLine +> "Nice to meet you, %." % [name]; nL +> halt + +We can transform any @TeletypeM@ into an @IO@ action, and run it: + +> main :: IO () +> main = runTeletypeIO hello + +@ + Hello! What's your name? + $ Dave + Nice to meet you, Dave. + This conversation can serve no purpose anymore. Goodbye. +@ + +When specifying DSLs in this way, we only need to define the semantics +for each of the actions; the plumbing of values is taken care of by +the generated monad instance. + diff --git a/examples/ValidationForm.hs b/examples/ValidationForm.hs --- a/examples/ValidationForm.hs +++ b/examples/ValidationForm.hs @@ -1,117 +1,113 @@ -{-# 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 ++ "\"!" - +module Main where + +import Control.Applicative.Free +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State + +import Data.Monoid (Sum(..)) + +import Text.Read (readEither) +import Text.Printf + +import System.IO + +-- | Field reader tries to read value or generates error message. +type FieldReader a = String -> Either String a + +-- | Convenient synonym for field name. +type Name = String + +-- | Convenient synonym for field help message. +type Help = String + +-- | A single field of a form. +data Field a = Field + { fName :: Name -- ^ Name. + , fValidate :: FieldReader a -- ^ Pure validation function. + , fHelp :: Help -- ^ Help message. + } + +-- | Validation form is just a free applicative over Field. +type Form = Ap Field + +-- | Build a form with a single field. +field :: Name -> FieldReader a -> Help -> Form a +field n f h = liftAp $ Field n f h + +-- | Singleton form accepting any input. +string :: Name -> Help -> Form String +string n h = field n Right h + +-- | Singleton form accepting anything but mentioned values. +available :: [String] -> Name -> Help -> Form String +available xs n h = field n check h + where + check x | x `elem` xs = Left "the value is not available" + | otherwise = Right x + +-- | Singleton integer field form. +int :: Name -> Form Int +int name = field name readEither "an integer value" + +-- | Generate help message for a form. +help :: Form a -> String +help = unlines . runAp_ (\f -> [fieldHelp f]) + +-- | Get help message for a field. +fieldHelp :: Field a -> String +fieldHelp (Field name _ msg) = printf " %-15s - %s" name msg + +-- | Count fields in a form. +count :: Form a -> Int +count = getSum . runAp_ (\_ -> Sum 1) + +-- | Interactive input of a form. +-- Shows progress on each field. +-- Repeats field input until it passes validation. +-- Show help message on empty input. +input :: Form a -> IO a +input m = evalStateT (runAp inputField m) 1 + where + inputField :: Field a -> StateT Int IO a + inputField f@(Field n g h) = do + i <- get + -- get field input with prompt + x <- liftIO $ do + putStr $ printf "[%d/%d] %s: " i (count m) n + hFlush stdout + getLine + case words x of + -- display help message for empty input + [] -> do + liftIO . putStrLn $ "help: " ++ h + inputField f + -- validate otherwise + _ -> case g x of + Right y -> do + modify (+ 1) + return y + Left e -> do + liftIO . putStrLn $ "error: " ++ e + inputField f + +-- | User datatype. +data User = User + { userName :: String + , userFullName :: String + , userAge :: Int } + deriving (Show) + +-- | Form for User. +form :: [String] -> Form User +form us = User + <$> available us "Username" "any vacant username" + <*> string "Full name" "your full name (e.g. John Smith)" + <*> int "Age" + +main :: IO () +main = do + putStrLn "Creating a new user." + putStrLn "Please, fill the form:" + user <- input (form ["bob", "alice"]) + putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!" + diff --git a/examples/free-examples.cabal b/examples/free-examples.cabal --- a/examples/free-examples.cabal +++ b/examples/free-examples.cabal @@ -1,121 +1,109 @@ -name: free-examples -category: Control, Monads -version: 0.1 -license: BSD3 -cabal-version: 1.18 -license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett -stability: provisional -homepage: http://github.com/ekmett/free/ -bug-reports: http://github.com/ekmett/free/issues -copyright: Copyright (C) 2008-2015 Edward A. Kmett -tested-with: GHC == 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 +stability: provisional +homepage: http://github.com/ekmett/free/ +bug-reports: http://github.com/ekmett/free/issues +copyright: Copyright (C) 2008-2015 Edward A. Kmett +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.6 + , GHC == 9.4.4 + , GHC == 9.6.1 +synopsis: Monads for free +description: Examples projects using @free@ +build-type: Simple + +source-repository head + type: git + location: git://github.com/ekmett/free.git + +flag mandelbrot-iter + default: True + +library + hs-source-dirs: . + default-language: Haskell2010 + exposed-modules: Cabbage + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 + +executable free-mandelbrot-iter + if !flag(mandelbrot-iter) + buildable: False + hs-source-dirs: . + default-language: Haskell2010 + main-is: MandelbrotIter.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + HGL >= 3.2.3.2, + mtl >= 2.0.1 && < 2.4, + transformers >= 0.2 && < 0.7 + +executable free-newton-coiter + hs-source-dirs: . + default-language: Haskell2010 + main-is: NewtonCoiter.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + comonad >= 4 && < 6, + free + +executable free-perf-th + hs-source-dirs: . + default-language: Haskell2010 + main-is: PerfTH.hs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + rdtsc, + transformers >= 0.2 && < 0.7 + +executable free-retry-th + hs-source-dirs: . + default-language: Haskell2010 + main-is: RetryTH.hs + ghc-options: -Wall -fno-warn-orphans + build-depends: + base >= 4.9 && < 5, + free, + transformers >= 0.2 && < 0.7, + transformers-compat >= 0.6.4 && < 0.8 + +executable free-teletype + hs-source-dirs: . + default-language: Haskell2010 + main-is: Teletype.lhs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + monad-loops + +executable free-validation-form + hs-source-dirs: . + default-language: Haskell2010 + main-is: ValidationForm.hs + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5, + free, + transformers >= 0.2 && < 0.7 diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,166 +1,126 @@ -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 -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: - - - -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 +name: free +category: Control, Monads +version: 5.2 +license: BSD3 +cabal-version: 1.18 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/free/ +bug-reports: http://github.com/ekmett/free/issues +copyright: Copyright (C) 2008-2015 Edward A. Kmett +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.6 + , GHC == 9.4.4 + , GHC == 9.6.1 +synopsis: Monads for free +description: + 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: + + + +build-type: Simple +extra-source-files: + .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 +extra-doc-files: + examples/*.hs + examples/*.lhs + +source-repository head + type: git + location: git://github.com/ekmett/free.git + +library + hs-source-dirs: src + + default-language: Haskell2010 + other-extensions: + MultiParamTypeClasses + FunctionalDependencies + FlexibleInstances + UndecidableInstances + Rank2Types + GADTs + + build-depends: + base >= 4.9 && < 5, + comonad >= 5.0.8 && < 6, + containers >= 0.5.7.1 && < 0.7, + distributive >= 0.5.2 && < 1, + exceptions >= 0.10.4 && < 0.11, + indexed-traversable >= 0.1.1 && < 0.2, + mtl >= 2.2.2 && < 2.4, + profunctors >= 5.6.1 && < 6, + semigroupoids >= 5.3.5 && < 6, + th-abstraction >= 0.4.2.0 && < 0.6, + transformers >= 0.5 && < 0.7, + transformers-base >= 0.4.5.2 && < 0.5, + template-haskell >= 2.11 && < 2.21 + + if !impl(ghc >= 8.2) + build-depends: bifunctor-classes-compat >= 0.1 && < 0.2 + + exposed-modules: + Control.Applicative.Free + Control.Applicative.Free.Fast + Control.Applicative.Free.Final + Control.Applicative.Trans.Free + Control.Alternative.Free + Control.Alternative.Free.Final + Control.Comonad.Cofree + Control.Comonad.Cofree.Class + Control.Comonad.Trans.Cofree + Control.Comonad.Trans.Coiter + Control.Monad.Free + Control.Monad.Free.Ap + Control.Monad.Free.Church + Control.Monad.Free.Class + Control.Monad.Free.TH + Control.Monad.Trans.Free + Control.Monad.Trans.Free.Ap + Control.Monad.Trans.Free.Church + Control.Monad.Trans.Iter + + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances + + if !impl(ghc >= 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + x-docspec-extra-packages: tagged diff --git a/include/free-common.h b/include/free-common.h deleted file mode 100644 --- a/include/free-common.h +++ /dev/null @@ -1,23 +0,0 @@ -#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 diff --git a/src/Control/Alternative/Free.hs b/src/Control/Alternative/Free.hs --- a/src/Control/Alternative/Free.hs +++ b/src/Control/Alternative/Free.hs @@ -1,164 +1,127 @@ -{-# 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 --- 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 #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Alternative.Free +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 + +#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 + +newtype Alt f a = Alt { alternatives :: [AltF f a] } + +instance Functor (AltF f) where + fmap f (Pure a) = Pure $ f a + fmap f (Ap x g) = x `Ap` fmap (f .) g + +instance Functor (Alt f) where + fmap f (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 #-} diff --git a/src/Control/Alternative/Free/Final.hs b/src/Control/Alternative/Free/Final.hs --- a/src/Control/Alternative/Free/Final.hs +++ b/src/Control/Alternative/Free/Final.hs @@ -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 --- 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 +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- Final encoding of free 'Alternative' functors. +---------------------------------------------------------------------------- +module Control.Alternative.Free.Final + ( Alt(..) + , runAlt + , liftAlt + , hoistAlt + ) where + +import Control.Applicative +import Data.Functor.Apply +import Data.Functor.Alt (()) +import qualified Data.Functor.Alt as Alt + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +-- | The free 'Alternative' for any @f@. +newtype Alt f a = Alt { _runAlt :: forall g. Alternative g => (forall x. f x -> g x) -> g a } + +instance Functor (Alt f) where + fmap f (Alt g) = Alt (\k -> fmap f (g k)) + +instance Apply (Alt f) where + Alt f <.> Alt x = Alt (\k -> f k <*> x k) + +instance Applicative (Alt f) where + pure x = Alt (\_ -> pure x) + Alt f <*> Alt x = Alt (\k -> f k <*> x k) + +instance Alt.Alt (Alt f) where + Alt x Alt y = Alt (\k -> x k <|> y k) + +instance Alternative (Alt f) where + empty = Alt (\_ -> empty) + Alt x <|> Alt y = Alt (\k -> x k <|> y k) + some (Alt x) = Alt $ \k -> some (x k) + many (Alt x) = Alt $ \k -> many (x k) + +instance Semigroup (Alt f a) where + (<>) = (<|>) + +instance Monoid (Alt f a) where + mempty = empty + mappend = (<>) + +-- | A version of 'lift' that can be used with @f@. +liftAlt :: f a -> Alt f a +liftAlt f = Alt (\k -> k f) + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. +runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a +runAlt phi g = _runAlt g phi + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@. +hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b +hoistAlt phi (Alt g) = Alt (\k -> g (k . phi)) + diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -1,144 +1,331 @@ -{-# 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 --- 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 , - -- 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 - - - --} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Free +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 , + -- by Paolo Capriotti and Ambrus Kaposi, for some applications. + + Ap(..) + , runAp + , runAp_ + , liftAp + , iterAp + , hoistAp + , retractAp + + -- * Examples + -- $examples + ) where + +import Control.Applicative +import Control.Comonad (Comonad(..)) +import Data.Functor.Apply +import Data.Foldable +import Data.Semigroup.Foldable +import Data.Functor.Classes + +import Prelude hiding (null) + +-- | The free 'Applicative' for a 'Functor' @f@. +data Ap f a where + Pure :: a -> Ap f a + Ap :: f a -> Ap f (a -> b) -> Ap f b + +-- | 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) + +-- | @foldMap f == foldMap f . 'runAp' 'Data.Foldable.toList'@ +instance Foldable f => Foldable (Ap f) where + foldMap f (Pure a) = f a + foldMap f (Ap x y) = foldMap (\a -> foldMap (\g -> f (g a)) y) x + + null (Pure _) = False + null (Ap x y) = null x || null y + + length = go 1 + where + -- This type annotation is required to do polymorphic recursion + go :: Foldable t => Int -> Ap t a -> Int + go n (Pure _) = n + go n (Ap x y) = case n * length x of + 0 -> 0 + n' -> go n' y + +-- | @foldMap f == foldMap f . 'runAp' 'toNonEmpty'@ +instance Foldable1 f => Foldable1 (Ap f) where + foldMap1 f (Pure a) = f a + foldMap1 f (Ap x y) = foldMap1 (\a -> foldMap1 (\g -> f (g a)) y) x + + +{- $note_eq1 + +This comment section is an internal documentation, but written in proper +Haddock markup. It is to allow rendering them to ease reading this rather long document. + +=== About the definition of @Eq1 (Ap f)@ instance + +The @Eq1 (Ap f)@ instance below has a complex definition. This comment +explains why it is defined like that. + +The discussion given here also applies to @Ord1 (Ap f)@ instance with a little change. + +==== General discussion about @Eq1@ type class + +Currently, there isn't a law on the @Eq1@ type class, but the following +properties can be expected. + +* If @Eq (f ())@, and @Functor f@ holds, @Eq1 f@ satisfies + + > liftEq (\_ _ -> True) x y == (() <$ x) == (() <$ y) + +* If @Foldable f@ holds, @Eq1 f@ satisfies: + + * @boringEq x y@ implies @length (toList x) == length (toList y)@ + + * @liftEq eq x y == liftEq (\_ _ -> True) && all (\(a,b) -> eq a b)) (zip (toList x) (toList y))@ + +Let's define the commonly used function @liftEq (\\_ _ -> True)@ as @boringEq@. + +> boringEq :: Eq1 f => f a -> f b -> Bool +> boringEq = liftEq (\_ _ -> True) + +Changing the constant @True@ to the constant @False@ in the definition of +@boringEq@, let @emptyEq@ function be defined as: + +> emptyEq :: Eq1 f => f a -> f b -> Bool +> emptyEq = liftEq (\_ _ -> False) + +From the above properties expectated on a @Eq1@ instance, @emptyEq@ satisfies the following. + +> emptyEq x y = boringEq x y && null (zip (toList x) (toList y)) + +==== About @instance (Eq1 (Ap f))@ + +If we're to define @Eq1 (Ap f)@ satisfying these properties as expected, @Eq (Ap f ())@ will determine +how @liftEq@ should behave. It's not unreasonable to define equality between @Ap f ()@ as below. + +> boringEqAp (Pure _) (Pure _) = True +> boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2 +> {- = ((() <$ x1) == (() <$ x2)) && (y1 == y2) -} +> boringEqAp _ _ = False + +Its type can be more general than equality between @Ap f ()@: + +> boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool + +Using @boringEqAp@, the specification of @liftEq@ will be: + +> liftEq eq x y = boringEqAp x y && and (zipWith eq (toList x) (toList y)) + +Then unfold @toList@ to remove the dependency to @Foldable@. + +> liftEq eq (Pure a1) (Pure a2) +> = boringEqAp (Pure a1) (Pure a2) && all (\(a,b) -> eq a b)) (zip (toList (Pure x)) (toList Pure y)) +> = True && all (\(a,b) -> eq a b) (zip [a1] [a2]) +> = eq a1 a2 +> liftEq eq (Ap x1 y1) (Ap x2 y2) +> = boringEqAp (Ap x1 y1) (Ap x2 y2) && all (\(b1, b2) -> eq b1 b2) (zip (toList (Ap x1 y1)) (toList (Ap x2 y2))) +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (toList x1 <**> toList y1) (toList x2 <**> toList y2)) +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (as1 <**> gs1) (as2 <**> gs2)) +> where as1 = toList x1 +> as2 = toList x2 +> gs1 = toList y1 +> gs2 = toList y2 +> = boringEq x1 y1 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) + +If @zip as1 as2@ is /not/ empty, the following transformation is valid. + +> (...) | not (null (zip as1 as2)) +> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> = boringEq x1 x2 && all (\(a1, a2) -> boringEqAp y1 y2 && all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +> = boringEq x1 x2 && all (\(a1, a2) -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) (zip as1 as2) +> = liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 + +Because, generally, the following transformation is valid if @xs@ is a nonempty list. + +> cond && all p xs = all (\x -> cond && p x) xs -- Only when xs is not empty! + +If @zip as1 as2@ is empty, @all (...) (zip as1 as2)@ is vacuously true, so the following transformation is valid. + +> (...) | null (zip as1 as2) +> = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2) +> = boringEq x1 x2 && boringEqAp y1 y2 + +Combining two cases: + +> liftEq eq (Ap x1 y1) (Ap x2 y2) +> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2 +> || not (null (zip as1 as2)) && liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 +> = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2 +> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 +> = emptyEq x1 x2 && boringEqAp y1 y2 +> || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2 + +The property about @emptyEq@ is used in the last equation. + +Hence it's defined as this source code. + +-} + +-- | Specialized 'boringEq' for @Ap f@. +boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool +boringEqAp (Pure _) (Pure _) = True +boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2 +boringEqAp _ _ = False + +-- | Implementaion of 'liftEq' for @Ap f@. +liftEqAp :: Eq1 f => (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool +liftEqAp eq (Pure a1) (Pure a2) = eq a1 a2 +liftEqAp eq (Ap x1 y1) (Ap x2 y2) + -- This branching is necessary and not just an optimization. + -- See the above comment for more + | emptyEq x1 x2 = boringEqAp y1 y2 + | otherwise = + liftEq (\a1 a2 -> liftEqAp (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) x1 x2 +liftEqAp _ _ _ = False + +-- | @boringEq fa fb@ tests if @fa@ and @fb@ are equal ignoring any difference between +-- their content (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'boring\' because the type parameters @a@ and @b@ are +-- treated as if they are the most boring type @()@. +boringEq :: Eq1 f => f a -> f b -> Bool +boringEq = liftEq (\_ _ -> True) + +-- | @emptyEq fa fb@ tests if @fa@ and @fb@ are equal /and/ they don't have any content +-- (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'empty\' because it only tests for values without any content, +-- like an empty list or @Nothing@. +-- +-- If @f@ is also @Foldable@, @emptyEq fa fb@ would be equivalent to +-- @null fa && null fb && liftEq eq@ for any @eq :: a -> b -> Bool@. +-- +-- (It depends on each instance of @Eq1@. Since @Eq1@ does not have +-- any laws currently, this is not a hard guarantee. But all instances in "base", "transformers", +-- "containers", "array", and "free" satisfy it.) +-- +-- Note that @emptyEq@ is not a equivalence relation, since it's possible @emptyEq x x == False@. +emptyEq :: Eq1 f => f a -> f b -> Bool +emptyEq = liftEq (\_ _ -> False) + +instance Eq1 f => Eq1 (Ap f) where + liftEq = liftEqAp + +instance (Eq1 f, Eq a) => Eq (Ap f a) where + (==) = eq1 + +-- | Specialized 'boringCompare' for @Ap f@. +boringCompareAp :: Ord1 f => Ap f a -> Ap f b -> Ordering +boringCompareAp (Pure _) (Pure _) = EQ +boringCompareAp (Pure _) (Ap _ _) = LT +boringCompareAp (Ap x1 y1) (Ap x2 y2) = boringCompare x1 x2 `mappend` boringCompareAp y1 y2 +boringCompareAp (Ap _ _) (Pure _) = GT + +-- | Implementation of 'liftCompare' for @Ap f@ +liftCompareAp :: Ord1 f => (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering +liftCompareAp cmp (Pure a1) (Pure a2) = cmp a1 a2 +liftCompareAp _ (Pure _) (Ap _ _) = LT +liftCompareAp cmp (Ap x1 y1) (Ap x2 y2) + -- This branching is necessary and not just an optimization. + -- See the above comment for more + | emptyEq x1 x2 = boringCompareAp y1 y2 + | otherwise = liftCompare (\a1 a2 -> liftCompareAp (\g1 g2 -> cmp (g1 a1) (g2 a2)) y1 y2) x1 x2 +liftCompareAp _ (Ap _ _) (Pure _) = GT + +-- | @boringCompare fa fb@ compares @fa@ and @fb@ ignoring any difference between +-- their content (the values of their last parameters @a@ and @b@.) +-- +-- It is named \'boring\' because the type parameters @a@ and @b@ are +-- treated as if they are the most boring type @()@. +boringCompare :: Ord1 f => f a -> f b -> Ordering +boringCompare = liftCompare (\_ _ -> EQ) + +instance Ord1 f => Ord1 (Ap f) where + liftCompare = liftCompareAp + +instance (Ord1 f, Ord a) => Ord (Ap f a) where + compare = compare1 + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp x = Ap x (Pure id) +{-# INLINE liftAp #-} + +-- | Tear down a free 'Applicative' using iteration. +iterAp :: Functor g => (g a -> a) -> Ap g a -> a +iterAp algebra = go + where go (Pure a) = a + go (Ap underlying apply) = algebra (go . (apply <*>) . pure <$> underlying) + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b +hoistAp _ (Pure a) = Pure a +hoistAp f (Ap x y) = Ap (f x) (hoistAp f y) + +-- | 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 + +{- $examples + + + +-} diff --git a/src/Control/Applicative/Free/Fast.hs b/src/Control/Applicative/Free/Fast.hs --- a/src/Control/Applicative/Free/Fast.hs +++ b/src/Control/Applicative/Free/Fast.hs @@ -1,169 +1,121 @@ -{-# 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 . --------------------------------------------------------------------------------- -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 GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- +-- | +-- A faster free applicative. +-- Based on . +-------------------------------------------------------------------------------- +module Control.Applicative.Free.Fast + ( + -- * The Sequence of Effects + ASeq(..) + , reduceASeq + , hoistASeq + , traverseASeq + , rebaseASeq + -- * The Faster Free Applicative + , Ap(..) + , liftAp + , retractAp + , runAp + , runAp_ + , hoistAp + ) where + +import Control.Applicative +import Data.Functor.Apply + +-- | The free applicative is composed of a sequence of effects, +-- and a pure function to apply that sequence to. +-- The fast free applicative separates these from each other, +-- so that the sequence may be built up independently, +-- and so that 'fmap' can run in constant time by having immediate access to the pure function. +data ASeq f a where + ANil :: ASeq f () + ACons :: f a -> ASeq f u -> ASeq f (a,u) + +-- | Interprets the sequence of effects using the semantics for +-- `pure` and `<*>` given by the Applicative instance for 'f'. +reduceASeq :: Applicative f => ASeq f u -> f u +reduceASeq ANil = pure () +reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs + +-- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@. +hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a +hoistASeq _ ANil = ANil +hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs) + +-- | Traverse a sequence with resepect to its interpretation type 'f'. +traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a) +traverseASeq _ ANil = pure ANil +traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f xs + +-- | It may not be obvious, but this essentially acts like ++, +-- traversing the first sequence and creating a new one by appending the second sequence. +-- The difference is that this also has to modify the return functions and that the return type depends on the input types. +-- +-- See the source of 'hoistAp' as an example usage. +rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) -> + (v -> u -> y) -> ASeq f v -> z +rebaseASeq ANil k f = k (\v -> f v ()) +rebaseASeq (ACons x xs) k f = + rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s)) + (\v u a -> f v (a,u)) + + +-- | The faster free 'Applicative'. +newtype Ap f a = Ap + { unAp :: forall u y z. + (forall x. (x -> y) -> ASeq f x -> z) -> + (u -> a -> y) -> ASeq f u -> z } + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp u = retractAp . hoistAp u + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: Ap f a -> Int +-- count = getSum . runAp_ (\\_ -> Sum 1) +-- @ +runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m +runAp_ f = getConst . runAp (Const . f) + +instance Functor (Ap f) where + fmap g x = Ap (\k f -> unAp x k (\s -> f s . g)) + +instance Apply (Ap f) where + (<.>) = (<*>) + +instance Applicative (Ap f) where + pure a = Ap (\k f -> k (`f` a)) + x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a))) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s)) +{-# INLINE liftAp #-} + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a +hoistAp g x = Ap (\k f s -> + unAp x + (\f' s' -> + rebaseASeq (hoistASeq g s') k + (\v u -> f v (f' u)) s) + (const id) + ANil) + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil diff --git a/src/Control/Applicative/Free/Final.hs b/src/Control/Applicative/Free/Final.hs --- a/src/Control/Applicative/Free/Final.hs +++ b/src/Control/Applicative/Free/Final.hs @@ -1,91 +1,85 @@ -{-# 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 --- 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 - - - --} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Free.Final +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- Final encoding of free 'Applicative' functors. +---------------------------------------------------------------------------- +module Control.Applicative.Free.Final + ( + -- | Compared to the free monad, they are less expressive. However, they are also more + -- flexible to inspect and interpret, as the number of ways in which + -- the values can be nested is more limited. + + Ap(..) + , runAp + , runAp_ + , liftAp + , hoistAp + , retractAp + + -- * Examples + -- $examples + ) where + +import Control.Applicative +import Data.Functor.Apply + +-- | The free 'Applicative' for a 'Functor' @f@. +newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a } + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp phi m = _runAp m phi + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: Ap f a -> Int +-- count = getSum . runAp_ (\\_ -> Sum 1) +-- @ +runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m +runAp_ f = getConst . runAp (Const . f) + +instance Functor (Ap f) where + fmap f (Ap g) = Ap (\k -> fmap f (g k)) + +instance Apply (Ap f) where + Ap f <.> Ap x = Ap (\k -> f k <*> x k) + +instance Applicative (Ap f) where + pure x = Ap (\_ -> pure x) + Ap f <*> Ap x = Ap (\k -> f k <*> x k) + +-- | A version of 'lift' that can be used with just a 'Functor' for @f@. +liftAp :: f a -> Ap f a +liftAp x = Ap (\k -> k x) + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b +hoistAp f (Ap g) = Ap (\k -> g (k . f)) + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp (Ap g) = g id + +{- $examples + + + +-} diff --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs --- a/src/Control/Applicative/Trans/Free.hs +++ b/src/Control/Applicative/Trans/Free.hs @@ -1,233 +1,191 @@ -{-# 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 --- Stability : provisional --- Portability : GADTs, Rank2Types --- --- 'Applicative' functor transformers for free ----------------------------------------------------------------------------- -module Control.Applicative.Trans.Free - ( - -- | Compared to the free monad transformers, they are less expressive. However, they are also more - -- flexible to inspect and interpret, as the number of ways in which - -- the values can be nested is more limited. - -- - -- See , - -- by Paolo Capriotti and Ambrus Kaposi, for some applications. - ApT(..) - , ApF(..) - , liftApT - , liftApO - , runApT - , runApF - , runApT_ - , hoistApT - , hoistApF - , transApT - , transApF - , joinApT - -- * Free Applicative - , Ap - , runAp - , runAp_ - , retractAp - -- * Free Alternative - , Alt - , runAlt - ) where - -import Control.Applicative -import Control.Monad (liftM) -import Data.Functor.Apply -import Data.Functor.Identity -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 Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Trans.Free +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs, Rank2Types +-- +-- 'Applicative' functor transformers for free +---------------------------------------------------------------------------- +module Control.Applicative.Trans.Free + ( + -- | Compared to the free monad transformers, they are less expressive. However, they are also more + -- flexible to inspect and interpret, as the number of ways in which + -- the values can be nested is more limited. + -- + -- See , + -- by Paolo Capriotti and Ambrus Kaposi, for some applications. + ApT(..) + , ApF(..) + , liftApT + , liftApO + , runApT + , runApF + , runApT_ + , hoistApT + , hoistApF + , transApT + , transApF + , joinApT + -- * Free Applicative + , Ap + , runAp + , runAp_ + , retractAp + -- * Free Alternative + , Alt + , runAlt + ) where + +import Control.Applicative +import Control.Monad (liftM) +import Data.Functor.Apply +import Data.Functor.Identity + +-- | The free 'Applicative' for a 'Functor' @f@. +data ApF f g a where + Pure :: a -> ApF f g a + Ap :: f a -> ApT f g (a -> b) -> ApF f g b + +-- | The free 'Applicative' transformer for a 'Functor' @f@ over +-- 'Applicative' @g@. +newtype ApT f g a = ApT { getApT :: g (ApF f g a) } + +instance Functor g => Functor (ApF f g) where + fmap f (Pure a) = Pure (f a) + fmap f (Ap x g) = x `Ap` fmap (f .) g + +instance Functor g => Functor (ApT f g) where + fmap f (ApT g) = ApT (fmap f <$> g) + +instance Applicative g => Applicative (ApF f g) where + pure = Pure + {-# INLINE pure #-} + Pure f <*> y = fmap f y -- fmap + y <*> Pure a = fmap ($ a) y -- interchange + Ap a f <*> b = a `Ap` (flip <$> f <*> ApT (pure b)) + {-# INLINE (<*>) #-} + +instance Applicative g => Applicative (ApT f g) where + pure = ApT . pure . pure + {-# INLINE pure #-} + ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys) + {-# INLINE (<*>) #-} + +instance Applicative g => Apply (ApF f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Applicative g => Apply (ApT f g) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Alternative g => Alternative (ApT f g) where + empty = ApT empty + {-# INLINE empty #-} + ApT g <|> ApT h = ApT (g <|> h) + {-# INLINE (<|>) #-} + +-- | A version of 'lift' that can be used with no constraint for @f@. +liftApT :: Applicative g => f a -> ApT f g a +liftApT x = ApT (pure (Ap x (pure id))) + +-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@. +liftApO :: Functor g => g a -> ApT f g a +liftApO g = ApT (Pure <$> g) + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApF f g ~> h@. +runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b +runApF _ _ (Pure x) = pure x +runApF f g (Ap x y) = f x <**> runApT f g y + +-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives +-- a natural transformation @ApT f g ~> h@. +runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b +runApT f g (ApT a) = g (runApF f g <$> a) + +-- | Perform a monoidal analysis over @'ApT' f g b@ value. +-- +-- Examples: +-- +-- @ +-- height :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int' +-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'maximum' +-- @ +-- +-- @ +-- size :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int' +-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'fold' +-- @ +runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m +runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst) + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@. +hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b +hoistApF _ (Pure x) = Pure x +hoistApF f (Ap x y) = f x `Ap` hoistApT f y + +-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@. +hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b +hoistApT f (ApT g) = ApT (hoistApF f <$> g) + +-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@. +transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b +transApF _ (Pure x) = Pure x +transApF f (Ap x y) = x `Ap` transApT f y + +-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@. +transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b +transApT f (ApT g) = ApT $ f (transApF f <$> g) + +-- | Pull out and join @m@ layers of @'ApT' f m a@. +joinApT :: Monad m => ApT f m a -> m (Ap f a) +joinApT (ApT m) = m >>= joinApF + where + joinApF (Pure x) = return (pure x) + joinApF (Ap x y) = (liftApT x <**>) `liftM` joinApT y + +-- | The free 'Applicative' for a 'Functor' @f@. +type Ap f = ApT f Identity + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp f = runApT f runIdentity + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: 'Ap' f a -> 'Int' +-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1) +-- @ +runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m +runAp_ f = runApT_ f runIdentity + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp = runAp id + +-- | The free 'Alternative' for a 'Functor' @f@. +type Alt f = ApT f [] + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. +runAlt :: (Alternative g, Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a +runAlt f (ApT xs) = foldr (\x acc -> h x <|> acc) empty xs + where + h (Pure x) = pure x + h (Ap x g) = f x <**> runAlt f g diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs --- a/src/Control/Comonad/Cofree.hs +++ b/src/Control/Comonad/Cofree.hs @@ -1,507 +1,400 @@ -{-# 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 --- 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 --- by Neil Ghani et al., Section 4.3 --- for more details. --- --- In particular, if @f a ≡ [a]@, the --- resulting data structure is a . --- For a practical application, check --- by Neil Ghani et al. -data Cofree f a = a :< f (Cofree f a) -#if __GLASGOW_HASKELL__ >= 707 - deriving (Typeable, 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Cofree +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 +import Data.Functor.Extend +import Data.Functor.WithIndex +import Data.Data +import Data.Distributive +import Data.Foldable +import Data.Foldable.WithIndex +import Data.Semigroup +import Data.Traversable +import Data.Traversable.WithIndex +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import GHC.Generics hiding (Infix, Prefix) +import Prelude hiding (id,(.)) + + +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 +-- by Neil Ghani et al., Section 4.3 +-- for more details. +-- +-- In particular, if @f a ≡ [a]@, the +-- resulting data structure is a . +-- For a practical application, check +-- by Neil Ghani et al. +data Cofree f a = a :< f (Cofree f a) + deriving (Generic, Generic1) + +deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a) + +-- | Use coiteration to generate a cofree comonad from a seed. +-- +-- @'coiter' f = 'unfold' ('id' 'Control.Arrow.&&&' f)@ +coiter :: Functor f => (a -> f a) -> a -> Cofree f a +coiter psi a = a :< (coiter psi <$> psi a) + +-- | Like coiter for comonadic values. +coiterW :: (Comonad w, Functor f) => (w a -> f (w a)) -> w a -> Cofree f a +coiterW psi a = extract a :< (coiterW psi <$> psi a) + +-- | Unfold a cofree comonad from a seed. +unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a +unfold f c = case f c of + (x, d) -> x :< fmap (unfold f) d + +-- | Unfold a cofree comonad from a seed, monadically. +unfoldM :: (Traversable f, Monad m) => (b -> m (a, f b)) -> b -> m (Cofree f a) +unfoldM f = f >=> \ (x, t) -> (x :<) `liftM` Data.Traversable.mapM (unfoldM f) t + +hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a +hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y) + +instance Functor f => ComonadCofree f (Cofree f) where + unwrap (_ :< as) = as + {-# INLINE unwrap #-} + +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 (<*>) #-} + +instance (Show1 f) => Show1 (Cofree f) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (a :< as) = showParen (d > 5) $ + sp 6 a . showString " :< " . liftShowsPrec go goList 5 as + +instance (Show1 f, Show a) => Show (Cofree f a) where + showsPrec = showsPrec1 + +instance (Read1 f) => Read1 (Cofree f) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go d r = readParen (d > 5) + (\r' -> [(u :< v, w) | + (u, s) <- rp 6 r', + (":<", t) <- lex s, + (v, w) <- liftReadsPrec go goList 5 t]) r + +instance (Read1 f, Read a) => Read (Cofree f a) where + readsPrec = readsPrec1 + +instance (Eq1 f, Eq a) => Eq (Cofree f a) where + (==) = eq1 + +instance (Eq1 f) => Eq1 (Cofree f) where + liftEq eq = go + where + go (a :< as) (b :< bs) = eq a b && liftEq go as bs + +instance (Ord1 f, Ord a) => Ord (Cofree f a) where + compare = compare1 + +instance (Ord1 f) => Ord1 (Cofree f) where + liftCompare cmp = go + where + go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs + +instance Foldable f => Foldable (Cofree f) where + foldMap f = go where + go (a :< as) = f a `mappend` foldMap go as + {-# INLINE foldMap #-} + length = go 0 where + go s (_ :< as) = foldl' go (s + 1) as + +instance Foldable1 f => Foldable1 (Cofree f) where + foldMap1 f = go where + 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 #-} + +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 + go xxs@(x :< xs) | null xs = pure xxs + | otherwise = (:<) <$> f x <*> traverse go xs +{-# INLINE shoots #-} + +-- | A @Traversal'@ that gives access to all leaf @a@ elements of a +-- @'Cofree' g@ a, where leaf is defined as @x@ from @(x :< xs)@ where +-- @null xs@ is @True@. +-- +-- Because this doesn't give access to all values in the @'Cofree' g@, +-- it cannot be used to change types. +-- +-- @shoots :: Traversable g => Traversal' (Cofree g a) a@ +-- +-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to +-- use @null (toList xs)@ instead. +leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a) +leaves f = go + where + go (x :< xs) | null xs = (:< xs) <$> f x + | otherwise = (x :<) <$> traverse go xs +{-# INLINE leaves #-} diff --git a/src/Control/Comonad/Cofree/Class.hs b/src/Control/Comonad/Cofree/Class.hs --- a/src/Control/Comonad/Cofree/Class.hs +++ b/src/Control/Comonad/Cofree/Class.hs @@ -1,60 +1,55 @@ -{-# 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 --- 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 MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Cofree.Class +-- Copyright : (C) 2008-2011 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 + +-- | 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 diff --git a/src/Control/Comonad/Trans/Cofree.hs b/src/Control/Comonad/Trans/Cofree.hs --- a/src/Control/Comonad/Trans/Cofree.hs +++ b/src/Control/Comonad/Trans/Cofree.hs @@ -1,352 +1,242 @@ -{-# 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 --- 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Trans.Cofree +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 +import GHC.Generics hiding (Infix, Prefix) + +infixr 5 :< + +-- | This is the base functor of the cofree comonad transformer. +data CofreeF f a b = a :< f b + deriving (Eq,Ord,Show,Read,Generic,Generic1) + +instance Show1 f => Show2 (CofreeF f) where + liftShowsPrec2 spa _sla spb slb d (a :< fb) = + showParen (d > 5) $ + spa 6 a . showString " :< " . liftShowsPrec spb slb 6 fb + +instance (Show1 f, Show a) => Show1 (CofreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (CofreeF f) where + liftReadsPrec2 rpa _rla rpb rlb d = + readParen (d > 5) $ + (\r' -> [ (u :< v, w) + | (u, s) <- rpa 6 r' + , (":<", t) <- lex s + , (v, w) <- liftReadsPrec rpb rlb 6 t + ]) + +instance (Read1 f, Read a) => Read1 (CofreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (CofreeF f) where + liftEq2 eqa eqfb (a :< fb) (a' :< fb') = eqa a a' && liftEq eqfb fb fb' + +instance (Eq1 f, Eq a) => Eq1 (CofreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (CofreeF f) where + liftCompare2 cmpa cmpfb (a :< fb) (a' :< fb') = + case cmpa a a' of + LT -> LT + EQ -> liftCompare cmpfb fb fb' + GT -> GT + +instance (Ord1 f, Ord a) => Ord1 (CofreeF f a) where + liftCompare = liftCompare2 compare + +-- | Extract the head of the base functor +headF :: CofreeF f a b -> a +headF (a :< _) = a + +-- | 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)) } + +-- | 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 + 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)) + +deriving instance + ( Typeable f + , Data a, Data (f b), Data b + ) => Data (CofreeF f a b) + +deriving instance + ( Typeable f, Typeable w + , Data (w (CofreeF f a (CofreeT f w a))) + , Data a + ) => Data (CofreeT f w a) + +-- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a +-- lowerF = fmap extract . unwrap diff --git a/src/Control/Comonad/Trans/Coiter.hs b/src/Control/Comonad/Trans/Coiter.hs --- a/src/Control/Comonad/Trans/Coiter.hs +++ b/src/Control/Comonad/Trans/Coiter.hs @@ -1,265 +1,184 @@ -{-# 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 --- 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 - - - --} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Trans.Coiter +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- The coiterative comonad generated by a comonad +---------------------------------------------------------------------------- +module Control.Comonad.Trans.Coiter + ( + -- | + -- Coiterative comonads represent non-terminating, productive computations. + -- + -- They are the dual notion of iterative monads. While iterative computations + -- produce no values or eventually terminate with one, coiterative + -- computations constantly produce values and they never terminate. + -- + -- It's simpler form, 'Coiter', is an infinite stream of data. 'CoiterT' + -- extends this so that each step of the computation can be performed in + -- a comonadic context. + + -- * The coiterative comonad transformer + CoiterT(..) + -- * The coiterative comonad + , Coiter, coiter, runCoiter + -- * Generating coiterative comonads + , unfold + -- * Cofree comonads + , ComonadCofree(..) + -- * Examples + -- $example + ) where + +import Control.Arrow hiding (second) +import Control.Comonad +import Control.Comonad.Cofree.Class +import Control.Comonad.Env.Class +import Control.Comonad.Hoist.Class +import Control.Comonad.Store.Class +import Control.Comonad.Traced.Class +import Control.Comonad.Trans.Class +import Control.Category +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +import Data.Foldable +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Traversable +import Prelude hiding (id,(.)) + +-- | This is the coiterative comonad generated by a comonad +newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) } + +instance (Eq1 w) => Eq1 (CoiterT w) where + liftEq eq = go + where + go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 w) => Ord1 (CoiterT w) where + liftCompare cmp = go + where + go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 w) => Show1 (CoiterT w) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (CoiterT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "CoiterT" d x + +instance (Read1 w) => Read1 (CoiterT w) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "CoiterT" CoiterT + +-- | The coiterative comonad +type Coiter = CoiterT Identity + +-- | Prepends a result to a coiterative computation. +-- +-- prop> runCoiter . uncurry coiter == id +coiter :: a -> Coiter a -> Coiter a +coiter a as = CoiterT $ Identity (a,as) +{-# INLINE coiter #-} + +-- | Extracts the first result from a coiterative computation. +-- +-- prop> uncurry coiter . runCoiter == id +runCoiter :: Coiter a -> (a, Coiter a) +runCoiter = runIdentity . runCoiterT +{-# INLINE runCoiter #-} + +instance Functor w => Functor (CoiterT w) where + fmap f = CoiterT . fmap (bimap f (fmap f)) . runCoiterT + +instance Comonad w => Comonad (CoiterT w) where + extract = fst . extract . runCoiterT + {-# INLINE extract #-} + extend f = CoiterT . extend (\w -> (f (CoiterT w), extend f $ snd $ extract w)) . runCoiterT + +instance Foldable w => Foldable (CoiterT w) where + foldMap f = foldMap (bifoldMap f (foldMap f)) . runCoiterT + +instance Traversable w => Traversable (CoiterT w) where + traverse f = fmap CoiterT . traverse (bitraverse f (traverse f)) . runCoiterT + +instance ComonadTrans CoiterT where + lower = fmap fst . runCoiterT + +instance Comonad w => ComonadCofree Identity (CoiterT w) where + unwrap = Identity . snd . extract . runCoiterT + {-# INLINE unwrap #-} + +instance ComonadEnv e w => ComonadEnv e (CoiterT w) where + ask = ask . lower + {-# INLINE ask #-} + +instance ComonadHoist CoiterT where + cohoist g = CoiterT . fmap (second (cohoist g)) . g . runCoiterT + +instance ComonadTraced m w => ComonadTraced m (CoiterT w) where + trace m = trace m . lower + {-# INLINE trace #-} + +instance ComonadStore s w => ComonadStore s (CoiterT w) where + pos = pos . lower + peek s = peek s . lower + peeks f = peeks f . lower + seek = seek + seeks = seeks + experiment f = experiment f . lower + {-# INLINE pos #-} + {-# INLINE peek #-} + {-# INLINE peeks #-} + {-# INLINE seek #-} + {-# INLINE seeks #-} + {-# INLINE experiment #-} + +instance (Show1 w, Show a) => Show (CoiterT w a) where + showsPrec = showsPrec1 + +instance (Read1 w, Read a) => Read (CoiterT w a) where + readsPrec = readsPrec1 + +instance (Eq1 w, Eq a) => Eq (CoiterT w a) where + (==) = eq1 + {-# INLINE (==) #-} + +instance (Ord1 w, Ord a) => Ord (CoiterT w a) where + compare = compare1 + {-# INLINE compare #-} + +-- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed. +unfold :: Comonad w => (w a -> a) -> w a -> CoiterT w a +unfold psi = CoiterT . extend (extract &&& unfold psi . extend psi) + +deriving instance + ( Typeable w + , Data (w (a, CoiterT w a)) + , Data a + ) => Data (CoiterT w a) + +{- $example + + + +-} diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -1,503 +1,397 @@ -{-# 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 --- 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 (). --- --- 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free +-- Copyright : (C) 2008-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 +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 GHC.Generics +import Prelude hiding (foldr) + +-- $setup +-- >>> import Control.Applicative (Const (..)) +-- >>> import Data.Functor.Identity (Identity (..)) +-- >>> import Data.Monoid (First (..)) +-- >>> import Data.Tagged (Tagged (..)) +-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x)) +-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x)))) + +-- | The 'Free' 'Monad' for a 'Functor' @f@. +-- +-- /Formally/ +-- +-- 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 (). +-- +-- 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)) + deriving (Generic, Generic1) + +deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) + +instance Eq1 f => Eq1 (Free f) where + liftEq eq = go + where + go (Pure a) (Pure b) = eq a b + go (Free fa) (Free fb) = liftEq go fa fb + go _ _ = False + +instance (Eq1 f, Eq a) => Eq (Free f a) where + (==) = eq1 + +instance Ord1 f => Ord1 (Free f) where + liftCompare cmp = go + where + go (Pure a) (Pure b) = cmp a b + go (Pure _) (Free _) = LT + go (Free _) (Pure _) = GT + go (Free fa) (Free fb) = liftCompare go fa fb + +instance (Ord1 f, Ord a) => Ord (Free f a) where + compare = compare1 + +instance Show1 f => Show1 (Free f) where + liftShowsPrec sp sl = go + where + go d (Pure a) = showsUnaryWith sp "Pure" d a + go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa + +instance (Show1 f, Show a) => Show (Free f a) where + showsPrec = showsPrec1 + +instance Read1 f => Read1 (Free f) where + liftReadsPrec rp rl = go + where + go = readsData $ + readsUnaryWith rp "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free + +instance (Read1 f, Read a) => Read (Free f a) where + readsPrec = readsPrec1 + +instance Functor f => Functor (Free f) where + fmap f = go where + go (Pure a) = Pure (f a) + go (Free fa) = Free (go <$> fa) + {-# INLINE fmap #-} + +instance 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 MonadPlus v => MonadPlus (Free v) where + mzero = Free mzero + {-# INLINE mzero #-} + a `mplus` b = Free (return a `mplus` return b) + {-# INLINE mplus #-} + +-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". +instance MonadTrans Free where + lift = Free . liftM Pure + {-# INLINE lift #-} + +instance Foldable f => Foldable (Free f) where + foldMap f = go where + go (Pure a) = f a + go (Free fa) = foldMap go fa + {-# INLINE foldMap #-} + + foldr f = go where + go r free = + case free of + Pure a -> f a r + Free fa -> foldr (flip go) r fa + {-# INLINE foldr #-} + + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} + +instance Foldable1 f => Foldable1 (Free f) where + foldMap1 f = go where + go (Pure a) = f a + go (Free fa) = foldMap1 go fa + {-# INLINE foldMap1 #-} + +instance Traversable f => Traversable (Free f) where + traverse f = go where + go (Pure a) = Pure <$> f a + go (Free fa) = Free <$> traverse go fa + {-# INLINE traverse #-} + +instance Traversable1 f => Traversable1 (Free f) where + traverse1 f = go where + go (Pure a) = Pure <$> f a + go (Free fa) = Free <$> traverse1 go fa + {-# INLINE traverse1 #-} + +instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where + imap f (Pure a) = Pure $ f [] a + imap f (Free s) = Free $ imap (\i -> imap (f . (:) i)) s + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where + ifoldMap f (Pure a) = f [] a + ifoldMap f (Free s) = ifoldMap (\i -> ifoldMap (f . (:) i)) s + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where + itraverse f (Pure a) = Pure <$> f [] a + itraverse f (Free s) = Free <$> itraverse (\i -> itraverse (f . (:) i)) s + {-# INLINE itraverse #-} + +instance MonadWriter e m => MonadWriter e (Free m) where + tell = lift . tell + {-# INLINE tell #-} + listen = lift . listen . retract + {-# INLINE listen #-} + pass = lift . pass . retract + {-# INLINE pass #-} + +instance MonadReader e m => MonadReader e (Free m) where + ask = lift ask + {-# INLINE ask #-} + local f = lift . local f . retract + {-# INLINE local #-} + +instance MonadState s m => MonadState s (Free m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + +instance MonadError e m => MonadError e (Free m) where + throwError = lift . throwError + {-# INLINE throwError #-} + catchError as f = lift (catchError (retract as) (retract . f)) + {-# INLINE catchError #-} + +instance MonadCont m => MonadCont (Free m) where + callCC f = lift (callCC (retract . f . liftM lift)) + {-# INLINE callCC #-} + +instance 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, 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 #-} diff --git a/src/Control/Monad/Free/Ap.hs b/src/Control/Monad/Free/Ap.hs --- a/src/Control/Monad/Free/Ap.hs +++ b/src/Control/Monad/Free/Ap.hs @@ -1,449 +1,349 @@ -{-# 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 --- --- * --- --- * --------------------------------------------------------------------------------- -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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +-------------------------------------------------------------------------------- +-- | +-- \"Applicative Effects in Free Monads\" +-- +-- Often times, the '(\<*\>)' operator can be more efficient than 'ap'. +-- Conventional free monads don't provide any means of modeling this. +-- The free monad can be modified to make use of an underlying applicative. +-- But it does require some laws, or else the '(\<*\>)' = 'ap' law is broken. +-- When interpreting this free monad with 'foldFree', +-- the natural transformation must be an applicative homomorphism. +-- An applicative homomorphism @hm :: (Applicative f, Applicative g) => f x -> g x@ +-- will satisfy these laws. +-- +-- * @hm (pure a) = pure a@ +-- * @hm (f \<*\> a) = hm f \<*\> hm a@ +-- +-- This is based on the \"Applicative Effects in Free Monads\" series of articles by Will Fancher +-- +-- * +-- +-- * +-------------------------------------------------------------------------------- +module Control.Monad.Free.Ap + ( MonadFree(..) + , Free(..) + , retract + , liftF + , iter + , iterA + , iterM + , hoistFree + , foldFree + , toFreeT + , cutoff + , unfold + , unfoldM + , _Pure, _Free + ) where + +import Control.Applicative +import Control.Arrow ((>>>)) +import Control.Monad (liftM, MonadPlus(..), (>=>)) +import Control.Monad.Fix +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.Free.Ap as FreeT +import Control.Monad.Free.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class +import Control.Monad.Cont.Class +import Data.Functor.Bind +import Data.Functor.Classes +import Data.Foldable +import Data.Profunctor +import Data.Traversable +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Data +import GHC.Generics +import Prelude hiding (foldr) + +-- $setup +-- >>> import Control.Applicative (Const (..)) +-- >>> import Data.Functor.Identity (Identity (..)) +-- >>> import Data.Monoid (First (..)) +-- >>> import Data.Tagged (Tagged (..)) +-- >>> let preview l x = getFirst (getConst (l (Const . First . Just) x)) +-- >>> let review l x = runIdentity (unTagged (l (Tagged (Identity x)))) + +-- | A free monad given an applicative +data Free f a = Pure a | Free (f (Free f a)) + deriving (Generic, Generic1) + +deriving instance + ( Typeable f + , Data a, Data (f (Free f a)) + ) => Data (Free f a) + +instance Eq1 f => Eq1 (Free f) where + liftEq eq = go + where + go (Pure a) (Pure b) = eq a b + go (Free fa) (Free fb) = liftEq go fa fb + go _ _ = False + +instance (Eq1 f, Eq a) => Eq (Free f a) where + (==) = eq1 + +instance Ord1 f => Ord1 (Free f) where + liftCompare cmp = go + where + go (Pure a) (Pure b) = cmp a b + go (Pure _) (Free _) = LT + go (Free _) (Pure _) = GT + go (Free fa) (Free fb) = liftCompare go fa fb + +instance (Ord1 f, Ord a) => Ord (Free f a) where + compare = compare1 + +instance Show1 f => Show1 (Free f) where + liftShowsPrec sp sl = go + where + go d (Pure a) = showsUnaryWith sp "Pure" d a + go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa + +instance (Show1 f, Show a) => Show (Free f a) where + showsPrec = showsPrec1 + +instance Read1 f => Read1 (Free f) where + liftReadsPrec rp rl = go + where + go = readsData $ + readsUnaryWith rp "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free + +instance (Read1 f, Read a) => Read (Free f a) where + readsPrec = readsPrec1 + +instance Functor f => Functor (Free f) where + fmap f = go where + go (Pure a) = Pure (f a) + go (Free fa) = Free (go <$> fa) + {-# INLINE fmap #-} + +instance Apply f => Apply (Free f) where + Pure a <.> Pure b = Pure (a b) + Pure a <.> Free fb = Free $ fmap a <$> fb + Free fa <.> Pure b = Free $ fmap ($ b) <$> fa + Free fa <.> Free fb = Free $ fmap (<.>) fa <.> fb + +instance Applicative f => Applicative (Free f) where + pure = Pure + {-# INLINE pure #-} + Pure a <*> Pure b = Pure $ a b + Pure a <*> Free mb = Free $ fmap a <$> mb + Free ma <*> Pure b = Free $ fmap ($ b) <$> ma + Free ma <*> Free mb = Free $ fmap (<*>) ma <*> mb + +instance Apply f => Bind (Free f) where + Pure a >>- f = f a + Free m >>- f = Free ((>>- f) <$> m) + +instance Applicative f => Monad (Free f) where + return = pure + {-# INLINE return #-} + Pure a >>= f = f a + Free m >>= f = Free ((>>= f) <$> m) + +instance Applicative f => MonadFix (Free f) where + mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" + +-- | This violates the Alternative laws, handle with care. +instance Alternative v => Alternative (Free v) where + empty = Free empty + {-# INLINE empty #-} + a <|> b = Free (pure a <|> pure b) + {-# INLINE (<|>) #-} + +-- | This violates the MonadPlus laws, handle with care. +instance MonadPlus v => MonadPlus (Free v) where + mzero = Free mzero + {-# INLINE mzero #-} + a `mplus` b = Free (return a `mplus` return b) + {-# INLINE mplus #-} + +-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". +instance MonadTrans Free where + lift = Free . liftM Pure + {-# INLINE lift #-} + +instance Foldable f => Foldable (Free f) where + foldMap f = go where + go (Pure a) = f a + go (Free fa) = foldMap go fa + {-# INLINE foldMap #-} + + foldr f = go where + go r free = + case free of + Pure a -> f a r + Free fa -> foldr (flip go) r fa + {-# INLINE foldr #-} + + foldl' f = go where + go r free = + case free of + Pure a -> f r a + Free fa -> foldl' go r fa + {-# INLINE foldl' #-} + +instance Foldable1 f => Foldable1 (Free f) where + foldMap1 f = go where + go (Pure a) = f a + go (Free fa) = foldMap1 go fa + {-# INLINE foldMap1 #-} + +instance Traversable f => Traversable (Free f) where + traverse f = go where + go (Pure a) = Pure <$> f a + go (Free fa) = Free <$> traverse go fa + {-# INLINE traverse #-} + +instance Traversable1 f => Traversable1 (Free f) where + traverse1 f = go where + go (Pure a) = Pure <$> f a + go (Free fa) = Free <$> traverse1 go fa + {-# INLINE traverse1 #-} + +instance MonadWriter e m => MonadWriter e (Free m) where + tell = lift . tell + {-# INLINE tell #-} + listen = lift . listen . retract + {-# INLINE listen #-} + pass = lift . pass . retract + {-# INLINE pass #-} + +instance MonadReader e m => MonadReader e (Free m) where + ask = lift ask + {-# INLINE ask #-} + local f = lift . local f . retract + {-# INLINE local #-} + +instance MonadState s m => MonadState s (Free m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + +instance MonadError e m => MonadError e (Free m) where + throwError = lift . throwError + {-# INLINE throwError #-} + catchError as f = lift (catchError (retract as) (retract . f)) + {-# INLINE catchError #-} + +instance MonadCont m => MonadCont (Free m) where + callCC f = lift (callCC (retract . f . liftM lift)) + {-# INLINE callCC #-} + +instance Applicative f => MonadFree f (Free f) where + wrap = Free + {-# INLINE wrap #-} + +-- | +-- 'retract' is the left inverse of 'lift' and 'liftF' +-- +-- @ +-- 'retract' . 'lift' = 'id' +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => Free f a -> f a +retract = foldFree id + +-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration. +iter :: Applicative f => (f a -> a) -> Free f a -> a +iter _ (Pure a) = a +iter phi (Free m) = phi (iter phi <$> m) + +-- | Like 'iter' for applicative values. +iterA :: (Applicative p, Applicative f) => (f (p a) -> p a) -> Free f a -> p a +iterA _ (Pure x) = pure x +iterA phi (Free f) = phi (iterA phi <$> f) + +-- | Like 'iter' for monadic values. +iterM :: (Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a +iterM _ (Pure x) = return x +iterM phi (Free f) = phi (iterM phi <$> f) + +-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'Free' f@ to @'Free' g@. +hoistFree :: (Applicative f, Applicative g) => (forall a. f a -> g a) -> Free f b -> Free g b +hoistFree f = foldFree (liftF . f) + +-- | Given an applicative homomorphism, you get a monad homomorphism. +foldFree :: (Applicative f, Monad m) => (forall x . f x -> m x) -> Free f a -> m a +foldFree _ (Pure a) = return a +foldFree f (Free as) = f as >>= foldFree f + +-- | Convert a 'Free' monad from "Control.Monad.Free.Ap" to a 'FreeT.FreeT' monad +-- from "Control.Monad.Trans.Free.Ap". +-- WARNING: This assumes that 'liftF' is an applicative homomorphism. +toFreeT :: (Applicative f, Monad m) => Free f a -> FreeT.FreeT f m a +toFreeT = foldFree liftF + +-- | Cuts off a tree of computations at a given depth. +-- If the depth is 0 or less, no computation nor +-- monadic effects will take place. +-- +-- Some examples (n ≥ 0): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling 'retract . cutoff n' is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Applicative f) => Integer -> Free f a -> Free f (Maybe a) +cutoff n _ | n <= 0 = return Nothing +cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f +cutoff _ m = Just <$> m + +-- | Unfold a free monad from a seed. +unfold :: Applicative f => (b -> Either a (f b)) -> b -> Free f a +unfold f = f >>> either Pure (Free . fmap (unfold f)) + +-- | Unfold a free monad from a seed, monadically. +unfoldM :: (Applicative f, Traversable f, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) +unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) + +-- | This is @Prism' (Free f a) a@ in disguise +-- +-- >>> preview _Pure (Pure 3) +-- Just 3 +-- +-- >>> review _Pure 3 :: Free Maybe Int +-- Pure 3 +_Pure :: forall f m a p. (Choice p, Applicative m) + => p a (m a) -> p (Free f a) (m (Free f a)) +_Pure = dimap impure (either pure (fmap Pure)) . right' + where + impure (Pure x) = Right x + impure x = Left x + {-# INLINE impure #-} +{-# INLINE _Pure #-} + +-- | This is @Prism' (Free f a) (f (Free f a))@ in disguise +-- +-- >>> preview _Free (review _Free (Just (Pure 3))) +-- Just (Just (Pure 3)) +-- +-- >>> review _Free (Just (Pure 3)) +-- Free (Just (Pure 3)) +_Free :: forall f m a p. (Choice p, Applicative m) + => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a)) +_Free = dimap unfree (either pure (fmap Free)) . right' + where + unfree (Free x) = Right x + unfree x = Left x + {-# INLINE unfree #-} +{-# INLINE _Free #-} diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -1,253 +1,249 @@ -{-# 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 --- 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: --- --- * --- --- * ----------------------------------------------------------------------------- -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'. --- --- -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: --- --- * --- --- * --- --- and by Janis Voightländer. -improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a -improve m = fromF m -{-# INLINE improve #-} - - --- | Cuts off a tree of computations at a given depth. --- If the depth is 0 or less, no computation nor --- monadic effects will take place. --- --- Some examples (@n ≥ 0@): --- --- prop> cutoff 0 _ == return Nothing --- prop> cutoff (n+1) . return == return . Just --- prop> cutoff (n+1) . lift == lift . liftM Just --- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) --- --- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the --- steps in the iteration is terminating. -{-# INLINE cutoff #-} -cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a) -cutoff n m - | n <= 0 = return Nothing - | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m - | otherwise = cutoffI n m - -{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-} -{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-} -cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a) -cutoffI n m = F m' where - m' kp kf = runF m kpn kfn n where - kpn a i - | i <= 0 = kp Nothing - | otherwise = kp (Just a) - kfn fr i - | i <= 0 = kp Nothing - | otherwise = let - i' = i - 1 - in i' `seq` kf (fmap ($ i') fr) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free.Church +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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: +-- +-- * +-- +-- * +---------------------------------------------------------------------------- +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'. +-- +-- +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 #-} + + foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z + {-# INLINE foldl' #-} + +instance Traversable f => Traversable (F f) where + traverse f m = runF m (fmap return . f) (fmap wrap . sequenceA) + {-# INLINE traverse #-} + +instance Foldable1 f => Foldable1 (F f) where + foldMap1 f m = runF m f fold1 + +instance Traversable1 f => Traversable1 (F f) where + traverse1 f m = runF m (fmap return . f) (fmap wrap . sequence1) + +-- | This violates the MonadPlus laws, handle with care. +instance MonadPlus f => MonadPlus (F f) where + mzero = F (\_ kf -> kf mzero) + F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf))) + +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: +-- +-- * +-- +-- * +-- +-- and by Janis Voightländer. +improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a +improve m = fromF m +{-# INLINE improve #-} + + +-- | Cuts off a tree of computations at a given depth. +-- If the depth is 0 or less, no computation nor +-- monadic effects will take place. +-- +-- Some examples (@n ≥ 0@): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +{-# INLINE cutoff #-} +cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a) +cutoff n m + | n <= 0 = return Nothing + | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m + | otherwise = cutoffI n m + +{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-} +{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-} +cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a) +cutoffI n m = F m' where + m' kp kf = runF m kpn kfn n where + kpn a i + | i <= 0 = kp Nothing + | otherwise = kp (Just a) + kfn fr i + | i <= 0 = kp Nothing + | otherwise = let + i' = i - 1 + in i' `seq` kf (fmap ($ i') fr) diff --git a/src/Control/Monad/Free/Class.hs b/src/Control/Monad/Free/Class.hs --- a/src/Control/Monad/Free/Class.hs +++ b/src/Control/Monad/Free/Class.hs @@ -1,170 +1,160 @@ -{-# 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 --- 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 (). --- --- 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 DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if !(MIN_VERSION_transformers(0,6,0)) +{-# OPTIONS_GHC -Wno-deprecations #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free.Class +-- Copyright : (C) 2008-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 + +-- | +-- 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 (). +-- +-- See 'Control.Monad.Free.Free' for a more formal definition of the free 'Monad' +-- for a 'Functor'. +class Monad m => MonadFree f m | m -> f where + -- | Add a layer. + -- + -- @ + -- wrap (fmap f x) ≡ wrap (fmap return x) >>= f + -- @ + wrap :: f (m a) -> m a + default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a + wrap = join . lift . wrap . fmap return + +instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where + wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm + +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 diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs --- a/src/Control/Monad/Free/TH.hs +++ b/src/Control/Monad/Free/TH.hs @@ -1,475 +1,441 @@ -{-# 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 --- 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 - - (regular data type declaration) - - (GADT declaration) - --} +{-# LANGUAGE CPP #-} +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.TH +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Automatic generation of free monadic actions. +-- +---------------------------------------------------------------------------- +module Control.Monad.Free.TH + ( + -- * Free monadic actions + makeFree, + makeFree_, + makeFreeCon, + makeFreeCon_, + + -- * Documentation + -- $doc + + -- * Examples + -- $examples + ) where + +import Control.Arrow +import Control.Monad +import Data.Char (toLower) +import Data.List ((\\), nub) +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Ppr (pprint) +import Language.Haskell.TH.Syntax + +data Arg + = Captured Type Exp + | Param Type + deriving (Show) + +params :: [Arg] -> [Type] +params [] = [] +params (Param t : xs) = t : params xs +params (_ : xs) = params xs + +captured :: [Arg] -> [(Type, Exp)] +captured [] = [] +captured (Captured t e : xs) = (t, e) : captured xs +captured (_ : xs) = captured xs + +zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp] +zipExprs (p:ps) cs (Param _ : as) = p : zipExprs ps cs as +zipExprs ps (c:cs) (Captured _ _ : as) = c : zipExprs ps cs as +zipExprs _ _ _ = [] + +findTypeOrFail :: String -> Q Name +findTypeOrFail s = lookupTypeName s >>= maybe (fail $ s ++ " is not in scope") return + +findValueOrFail :: String -> Q Name +findValueOrFail s = lookupValueName s >>= maybe (fail $ s ++ "is not in scope") return + +-- | Pick a name for an operation. +-- For normal constructors it lowers first letter. +-- For infix ones it omits the first @:@. +mkOpName :: String -> Q String +mkOpName (':':name) = return name +mkOpName ( c :name) = return $ toLower c : name +mkOpName _ = fail "impossible happened: empty (null) constructor name" + +-- | Check if parameter is used in type. +usesTV :: Name -> Type -> Bool +usesTV n (VarT name) = n == name +usesTV n (AppT t1 t2) = any (usesTV n) [t1, t2] +usesTV n (SigT t _ ) = usesTV n t +usesTV n (ForallT bs _ t) = usesTV n t && n `notElem` map tvName bs +usesTV _ _ = False + +-- | Analyze constructor argument. +mkArg :: Type -> Type -> Q Arg +mkArg (VarT n) t + | usesTV n t = + case t of + -- if parameter is used as is, the return type should be () + -- as well as the corresponding expression + VarT _ -> return $ Captured (TupleT 0) (TupE []) + -- if argument is of type (a1 -> ... -> aN -> param) then the + -- return type is N-tuple (a1, ..., aN) and the corresponding + -- expression is an N-tuple secion (,...,). + AppT (AppT ArrowT _) _ -> do + (ts, name) <- arrowsToTuple t + when (any (usesTV n) ts) $ fail $ unlines + [ "type variable " ++ pprint n ++ " is forbidden" + , "in a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")" + , "in a constructor's argument type: " ++ pprint t ] + when (name /= n) $ fail $ unlines + [ "expected final return type `" ++ pprint n ++ "'" + , "but got `" ++ pprint name ++ "'" + , "in a constructor's argument type: `" ++ pprint t ++ "'" ] + let tup = nonUnaryTupleT ts + xs <- mapM (const $ newName "x") ts + return $ Captured tup (LamE (map VarP xs) (nonUnaryTupE $ map VarE xs)) + _ -> fail $ unlines + [ "expected a type variable `" ++ pprint n ++ "'" + , "or a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")" + , "but got `" ++ pprint t ++ "'" + , "in a constructor's argument" ] + | otherwise = return $ Param t + where + arrowsToTuple (AppT (AppT ArrowT t1) t2) = do + (ts, name) <- arrowsToTuple t2 + return (t1:ts, name) + arrowsToTuple (VarT name) = return ([], name) + arrowsToTuple rt = fail $ unlines + [ "expected final return type `" ++ pprint n ++ "'" + , "but got `" ++ pprint rt ++ "'" + , "in a constructor's argument type: `" ++ pprint t ++ "'" ] + + nonUnaryTupleT :: [Type] -> Type + nonUnaryTupleT [t'] = t' + nonUnaryTupleT ts = foldl AppT (TupleT $ length ts) ts + + nonUnaryTupE :: [Exp] -> Exp + nonUnaryTupE [e] = e + nonUnaryTupE es = TupE $ +#if MIN_VERSION_template_haskell(2,16,0) + map Just +#endif + es + +mkArg n _ = fail $ unlines + [ "expected a type variable" + , "but got `" ++ pprint n ++ "'" + , "as the last parameter of the type constructor" ] + +-- | Apply transformation to the return value independently of how many +-- parameters does @e@ have. +-- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to +-- @\x y z -> Just (x + y * z)@ +mapRet :: (Exp -> Exp) -> Exp -> Exp +mapRet f (LamE ps e) = LamE ps $ mapRet f e +mapRet f e = f e + +-- | Unification of two types. +-- @next@ with @a -> next@ gives @Maybe a@ return type +-- @a -> next@ with @b -> next@ gives @Either a b@ return type +unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp]) +unifyT (TupleT 0, _) (TupleT 0, _) = fail "can't accept 2 mere parameters" +unifyT (TupleT 0, _) (t, e) = do + maybe' <- ConT <$> findTypeOrFail "Maybe" + nothing' <- ConE <$> findValueOrFail "Nothing" + just' <- ConE <$> findValueOrFail "Just" + return (AppT maybe' t, [nothing', mapRet (AppE just') e]) +unifyT x y@(TupleT 0, _) = second reverse <$> unifyT y x +unifyT (t1, e1) (t2, e2) = do + either' <- ConT <$> findTypeOrFail "Either" + left' <- ConE <$> findValueOrFail "Left" + right' <- ConE <$> findValueOrFail "Right" + return (AppT (AppT either' t1) t2, [mapRet (AppE left') e1, mapRet (AppE right') e2]) + +-- | Unifying a list of types (possibly refining expressions). +-- Name is used when the return type is supposed to be arbitrary. +unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp]) +unifyCaptured a [] = return (VarT a, []) +unifyCaptured _ [(t, e)] = return (t, [e]) +unifyCaptured _ [x, y] = unifyT x y +unifyCaptured _ xs = fail $ unlines + [ "can't unify more than 2 return types" + , "that use type parameter" + , "when unifying return types: " + , unlines (map (pprint . fst) xs) ] + +extractVars :: Type -> [Name] +extractVars (ForallT bs _ t) = extractVars t \\ map tvName bs +extractVars (VarT n) = [n] +extractVars (AppT x y) = extractVars x ++ extractVars y +extractVars (SigT x k) = extractVars x ++ extractVars k +extractVars (InfixT x _ y) = extractVars x ++ extractVars y +extractVars (UInfixT x _ y) = extractVars x ++ extractVars y +extractVars (ParensT x) = extractVars x +extractVars _ = [] + +liftCon' :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec] +liftCon' typeSig tvbs cx f n ns cn ts = do + -- prepare some names + opName <- mkName <$> mkOpName (nameBase cn) + m <- newName "m" + a <- newName "a" + monadFree <- findTypeOrFail "MonadFree" + liftF <- findValueOrFail "liftF" + -- look at the constructor parameters + args <- mapM (mkArg n) ts + let ps = params args -- these are not using type parameter + cs = captured args -- these capture it somehow + -- based on cs we get return type and refined expressions + -- (e.g. with Nothing/Just or Left/Right tags) + (retType, es) <- unifyCaptured a cs + -- operation type is (a1 -> a2 -> ... -> aN -> m r) + let opType = foldr (AppT . AppT ArrowT) (AppT (VarT m) retType) ps + -- picking names for the implementation + xs <- mapM (const $ newName "p") ps + let pat = map VarP xs -- this is LHS + exprs = zipExprs (map VarE xs) es args -- this is what ctor would be applied to + fval = foldl AppE (ConE cn) exprs -- this is RHS without liftF + ns' = nub (concatMap extractVars ns) + q = filter nonNext tvbs ++ map plainTVSpecified (qa ++ m : ns') + qa = case retType of VarT b | a == b -> [a]; _ -> [] + f' = foldl AppT f ns + return $ concat + [ if typeSig + then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ] + else [] + , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ] + where + nonNext tv = VarT (tvName tv) /= n + +-- | Provide free monadic actions for a single value constructor. +liftCon :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec] +liftCon typeSig ts cx f n ns onlyCons con + | not (any (`melem` onlyCons) (constructorNames con)) = return [] + | otherwise = case con of + NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields + RecC cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields + InfixC (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2] + ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns onlyCons con' + GadtC cNames fields resType -> do + decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> + liftGadtC cName fields resType typeSig ts cx f + return (concat decs) + RecGadtC cNames fields resType -> do + let fields' = map (\(_, x, y) -> (x, y)) fields + decs <- forM (filter (`melem` onlyCons) cNames) $ \cName -> + liftGadtC cName fields' resType typeSig ts cx f + return (concat decs) + +splitAppT :: Type -> (Type, [Type]) +splitAppT ty = go ty ty [] + where + go :: Type -> Type -> [Type] -> (Type, [Type]) + go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) + go origTy (SigT ty' _) args = go origTy ty' args + go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args + go origTy (ParensT ty') args = go origTy ty' args + go origTy _ args = (origTy, args) + +liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Q [Dec] +liftGadtC cName fields resType typeSig ts cx f = + liftCon typeSig ts cx f nextTy (init tys) Nothing (NormalC cName fields) + where + (_f, tys) = splitAppT resType + nextTy = last tys + +melem :: Eq a => a -> Maybe [a] -> Bool +melem _ Nothing = True +melem x (Just xs) = x `elem` xs + +-- | Get construstor name(s). +constructorNames :: Con -> [Name] +constructorNames (NormalC name _) = [name] +constructorNames (RecC name _) = [name] +constructorNames (InfixC _ name _) = [name] +constructorNames (ForallC _ _ c) = constructorNames c +constructorNames (GadtC names _ _) = names +constructorNames (RecGadtC names _ _) = names + +-- | Provide free monadic actions for a type declaration. +liftDec :: Bool -- ^ Include type signature? + -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. + -> Dec -- ^ Data type declaration. + -> Q [Dec] +liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _) + | null tyVarBndrs = fail $ "Type constructor " ++ pprint tyName ++ " needs at least one type parameter" + | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTy (init tys) onlyCons) cons + where + tys = map (VarT . tvName) tyVarBndrs + nextTy = last tys + con = ConT tyName +liftDec _ _ dec = fail $ unlines + [ "failed to derive makeFree operations:" + , "expected a data type constructor" + , "but got " ++ pprint dec ] + +-- | Generate monadic actions for a data type. +genFree :: Bool -- ^ Include type signature? + -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. + -> Name -- ^ Type name. + -> Q [Dec] -- ^ Generated declarations. +genFree typeSig cnames tyCon = do + info <- reify tyCon + case info of + TyConI dec -> liftDec typeSig cnames dec + _ -> fail "makeFree expects a type constructor" + +-- | Generate monadic action for a single constructor of a data type. +genFreeCon :: Bool -- ^ Include type signature? + -> Name -- ^ Constructor name. + -> Q [Dec] -- ^ Generated declarations. +genFreeCon typeSig cname = do + info <- reify cname + case info of + DataConI _ _ tname -> genFree typeSig (Just [cname]) tname + _ -> fail $ unlines + [ "expected a data constructor" + , "but got " ++ pprint info ] + +-- | @$('makeFree' ''T)@ provides free monadic actions for the +-- constructors of the given data type @T@. +makeFree :: Name -> Q [Dec] +makeFree = genFree True Nothing + +-- | Like 'makeFree', but does not provide type signatures. +-- This can be used to attach Haddock comments to individual arguments +-- for each generated function. +-- +-- @ +-- data LangF x = Output String x +-- +-- makeFree_ 'LangF +-- +-- -- | Output a string. +-- output :: MonadFree LangF m => +-- String -- ^ String to output. +-- -> m () -- ^ No result. +-- @ +-- +-- 'makeFree_' must be called *before* the explicit type signatures. +makeFree_ :: Name -> Q [Dec] +makeFree_ = genFree False Nothing + +-- | @$('makeFreeCon' 'Con)@ provides free monadic action for a data +-- constructor @Con@. Note that you can attach Haddock comment to the +-- generated function by placing it before the top-level invocation of +-- 'makeFreeCon': +-- +-- @ +-- -- | Output a string. +-- makeFreeCon 'Output +-- @ +makeFreeCon :: Name -> Q [Dec] +makeFreeCon = genFreeCon True + +-- | Like 'makeFreeCon', but does not provide a type signature. +-- This can be used to attach Haddock comments to individual arguments. +-- +-- @ +-- data LangF x = Output String x +-- +-- makeFreeCon_ 'Output +-- +-- -- | Output a string. +-- output :: MonadFree LangF m => +-- String -- ^ String to output. +-- -> m () -- ^ No result. +-- @ +-- +-- 'makeFreeCon_' must be called *before* the explicit type signature. +makeFreeCon_ :: Name -> Q [Dec] +makeFreeCon_ = genFreeCon False + +{- $doc + To generate free monadic actions from a @Type@, it must be a @data@ + declaration (maybe GADT) with at least one free variable. For each constructor of the type, a + new function will be declared. + + Consider the following generalized definitions: + + > data Type a1 a2 … aN param = … + > | FooBar t1 t2 t3 … tJ + > | (:+) t1 t2 t3 … tJ + > | t1 :* t2 + > | t1 `Bar` t2 + > | Baz { x :: t1, y :: t2, …, z :: tJ } + > | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ + > | … + + where each of the constructor arguments @t1, …, tJ@ is either: + + 1. A type, perhaps depending on some of the @a1, …, aN@. + + 2. A type dependent on @param@, of the form @s1 -> … -> sM -> param@, M ≥ 0. + At most 2 of the @t1, …, tJ@ may be of this form. And, out of these two, + at most 1 of them may have @M == 0@; that is, be of the form @param@. + + For each constructor, a function will be generated. First, the name + of the function is derived from the name of the constructor: + + * For prefix constructors, the name of the constructor with the first + letter in lowercase (e.g. @FooBar@ turns into @fooBar@). + + * For infix constructors, the name of the constructor with the first + character (a colon @:@), removed (e.g. @:+@ turns into @+@). + + Then, the type of the function is derived from the arguments to the constructor: + + > … + > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > (+) :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > bar :: (MonadFree Type m) => t1 -> … -> tK' -> m ret + > baz :: (MonadFree Type m) => t1' -> … -> tK' -> m ret + > qux :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret + > … + + The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the + @a1, …, aN@. + + The type @ret@ depends on those constructor arguments that reference the + @param@ type variable: + + 1. If no arguments to the constructor depend on @param@, @ret ≡ a@, where + @a@ is a fresh type variable. + + 2. If only one argument in the constructor depends on @param@, then + @ret ≡ (s1, …, sM)@. In particular, if @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@. + + 3. If two arguments depend on @param@, (e.g. @u1 -> … -> uL -> param@ and + @v1 -> … -> vM -> param@, then @ret ≡ Either (u1, …, uL) (v1, …, vM)@. + + Note that @Either a ()@ and @Either () a@ are both isomorphic to @Maybe a@. + Because of this, when @L == 0@ or @M == 0@ in case 3., the type of + @ret@ is simplified: + + * @ret ≡ Either (u1, …, uL) ()@ is rewritten to @ret ≡ Maybe (u1, …, uL)@. + + * @ret ≡ Either () (v1, …, vM)@ is rewritten to @ret ≡ Maybe (v1, …, vM)@. + +-} + +{- $examples + + (regular data type declaration) + + (GADT declaration) + +-} diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -1,612 +1,449 @@ -{-# 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 --- 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Free +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 +import Data.Functor.Identity +import Data.Traversable +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +import GHC.Generics + +-- | The base functor for a free monad. +data FreeF f a b = Pure a | Free (f b) + deriving (Eq,Ord,Show,Read,Generic,Generic1,Data) + +instance Show1 f => Show2 (FreeF f) where + liftShowsPrec2 spa _sla _spb _slb d (Pure a) = + showsUnaryWith spa "Pure" d a + liftShowsPrec2 _spa _sla spb slb d (Free as) = + showsUnaryWith (liftShowsPrec spb slb) "Free" d as + +instance (Show1 f, Show a) => Show1 (FreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (FreeF f) where + liftReadsPrec2 rpa _rla rpb rlb = readsData $ + readsUnaryWith rpa "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free + +instance (Read1 f, Read a) => Read1 (FreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (FreeF f) where + liftEq2 eq _ (Pure a) (Pure b) = eq a b + liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs + liftEq2 _ _ _ _ = False + +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (FreeF f) where + liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b + liftCompare2 _ _ (Pure _) (Free _) = LT + liftCompare2 _ _ (Free _) (Pure _) = GT + liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb + +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + liftCompare = liftCompare2 compare + +instance Functor f => Functor (FreeF f a) where + fmap _ (Pure a) = Pure a + fmap f (Free as) = Free (fmap f as) + {-# INLINE fmap #-} + +instance Foldable f => Foldable (FreeF f a) where + foldMap f (Free as) = foldMap f as + foldMap _ _ = mempty + {-# INLINE foldMap #-} + +instance Traversable f => Traversable (FreeF f a) where + traverse _ (Pure a) = pure (Pure a) + traverse f (Free as) = Free <$> traverse f as + {-# INLINE traverse #-} + +instance Functor f => Bifunctor (FreeF f) where + bimap f _ (Pure a) = Pure (f a) + bimap _ g (Free as) = Free (fmap g as) + {-# INLINE bimap #-} + +instance Foldable f => Bifoldable (FreeF f) where + bifoldMap f _ (Pure a) = f a + bifoldMap _ g (Free as) = foldMap g as + {-# INLINE bifoldMap #-} + +instance Traversable f => Bitraversable (FreeF f) where + bitraverse f _ (Pure a) = Pure <$> f a + bitraverse _ g (Free as) = Free <$> traverse g as + {-# INLINE bitraverse #-} + +transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b +transFreeF _ (Pure a) = Pure a +transFreeF t (Free as) = Free (t as) +{-# INLINE transFreeF #-} + +-- | The \"free monad transformer\" for a functor @f@ +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 #-} + +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where + (==) = eq1 + +instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where + liftEq eq = go + where + go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where + compare = compare1 + +instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where + liftCompare cmp = go + where + go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 f, Show1 m) => Show1 (FreeT f m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (FreeT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "FreeT" d x + +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where + showsPrec = showsPrec1 + +instance (Read1 f, Read1 m) => Read1 (FreeT f m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "FreeT" FreeT + +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where + readsPrec = readsPrec1 + +instance (Functor f, Functor m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (fmap f' m) where + f' (Pure a) = Pure (f a) + f' (Free as) = Free (fmap (fmap f) as) + +instance (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, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Functor f, MonadWriter w m) => MonadWriter w (FreeT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Pure x, w) = Pure (x, w) + concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y + pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) + g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f) + +instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where + callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) + +instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where + empty = FreeT mzero + FreeT ma <|> FreeT mb = FreeT (mplus ma mb) + {-# 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 +-- @ +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) diff --git a/src/Control/Monad/Trans/Free/Ap.hs b/src/Control/Monad/Trans/Free/Ap.hs --- a/src/Control/Monad/Trans/Free/Ap.hs +++ b/src/Control/Monad/Trans/Free/Ap.hs @@ -1,600 +1,443 @@ -{-# 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- +-- | +-- Given an applicative, the free monad transformer. +-------------------------------------------------------------------------------- + +module Control.Monad.Trans.Free.Ap + ( + -- * The base functor + FreeF(..) + -- * The free monad transformer + , FreeT(..) + -- * The free monad + , Free, free, runFree + -- * Operations + , liftF + , iterT + , iterTM + , hoistFreeT + , transFreeT + , joinFreeT + , cutoff + , partialIterT + , intersperseT + , intercalateT + , retractT + -- * Operations of free monad + , retract + , iter + , iterM + -- * Free Monads With Class + , MonadFree(..) + ) where + +import Control.Applicative +import Control.Monad (liftM, MonadPlus(..), join) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Trans.Class +import qualified Control.Monad.Fail as Fail +import Control.Monad.Free.Class +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class +import Control.Monad.Cont.Class +import Data.Functor.Bind hiding (join) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Traversable +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Data +import GHC.Generics + +-- | The base functor for a free monad. +data FreeF f a b = Pure a | Free (f b) + deriving (Eq,Ord,Show,Read,Data,Generic,Generic1) + +instance Show1 f => Show2 (FreeF f) where + liftShowsPrec2 spa _sla _spb _slb d (Pure a) = + showsUnaryWith spa "Pure" d a + liftShowsPrec2 _spa _sla spb slb d (Free as) = + showsUnaryWith (liftShowsPrec spb slb) "Free" d as + +instance (Show1 f, Show a) => Show1 (FreeF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Read1 f => Read2 (FreeF f) where + liftReadsPrec2 rpa _rla rpb rlb = readsData $ + readsUnaryWith rpa "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free + +instance (Read1 f, Read a) => Read1 (FreeF f a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance Eq1 f => Eq2 (FreeF f) where + liftEq2 eq _ (Pure a) (Pure b) = eq a b + liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs + liftEq2 _ _ _ _ = False + +instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where + liftEq = liftEq2 (==) + +instance Ord1 f => Ord2 (FreeF f) where + liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b + liftCompare2 _ _ (Pure _) (Free _) = LT + liftCompare2 _ _ (Free _) (Pure _) = GT + liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb + +instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where + liftCompare = liftCompare2 compare + +instance Functor f => Functor (FreeF f a) where + fmap _ (Pure a) = Pure a + fmap f (Free as) = Free (fmap f as) + {-# INLINE fmap #-} + +instance Foldable f => Foldable (FreeF f a) where + foldMap f (Free as) = foldMap f as + foldMap _ _ = mempty + {-# INLINE foldMap #-} + +instance Traversable f => Traversable (FreeF f a) where + traverse _ (Pure a) = pure (Pure a) + traverse f (Free as) = Free <$> traverse f as + {-# INLINE traverse #-} + +instance Functor f => Bifunctor (FreeF f) where + bimap f _ (Pure a) = Pure (f a) + bimap _ g (Free as) = Free (fmap g as) + {-# INLINE bimap #-} + +instance Foldable f => Bifoldable (FreeF f) where + bifoldMap f _ (Pure a) = f a + bifoldMap _ g (Free as) = foldMap g as + {-# INLINE bifoldMap #-} + +instance Traversable f => Bitraversable (FreeF f) where + bitraverse f _ (Pure a) = Pure <$> f a + bitraverse _ g (Free as) = Free <$> traverse g as + {-# INLINE bitraverse #-} + +transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b +transFreeF _ (Pure a) = Pure a +transFreeF t (Free as) = Free (t as) +{-# INLINE transFreeF #-} + +-- | The \"free monad transformer\" for an applicative @f@ +newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) } + +-- | The \"free monad\" for an applicative @f@. +type Free f = FreeT f Identity + +-- | Evaluates the first layer out of a free monad value. +runFree :: Free f a -> FreeF f a (Free f a) +runFree = runIdentity . runFreeT +{-# INLINE runFree #-} + +-- | Pushes a layer into a free monad value. +free :: FreeF f a (Free f a) -> Free f a +free = FreeT . Identity +{-# INLINE free #-} + +deriving instance + ( Typeable f, Typeable m + , Data (m (FreeF f a (FreeT f m a))) + , Data a + ) => Data (FreeT f m a) + +instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where + (==) = eq1 + +instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where + liftEq eq = go + where + go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y + +instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where + compare = compare1 + +instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where + liftCompare cmp = go + where + go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Show1 f, Show1 m) => Show1 (FreeT f m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (FreeT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "FreeT" d x + +instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where + showsPrec = showsPrec1 + +instance (Read1 f, Read1 m) => Read1 (FreeT f m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "FreeT" FreeT + +instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where + readsPrec = readsPrec1 + +instance (Functor f, Functor m) => Functor (FreeT f m) where + fmap f (FreeT m) = FreeT (fmap f' m) where + f' (Pure a) = Pure (f a) + f' (Free as) = Free (fmap (fmap f) as) + +instance (Applicative f, Applicative m) => Applicative (FreeT f m) where + pure a = FreeT (pure (Pure a)) + {-# INLINE pure #-} + FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where + g (Pure f') (Pure a') = Pure (f' a') + g (Pure f') (Free as) = Free $ fmap f' <$> as + g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs + g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as + {-# INLINE (<*>) #-} + +instance (Apply f, Apply m) => Apply (FreeT f m) where + FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where + g (Pure f') (Pure a') = Pure (f' a') + g (Pure f') (Free as) = Free $ fmap f' <$> as + g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs + g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as + +instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where + FreeT m >>- f = FreeT $ m >>= \v -> case v of + Pure a -> runFreeT (f a) + Free w -> return (Free (fmap (>>- f) w)) + +instance (Applicative f, Monad m) => Monad (FreeT f m) where + return = pure + {-# INLINE return #-} + FreeT m >>= f = FreeT $ m >>= \v -> case v of + Pure a -> runFreeT (f a) + Free w -> return (Free (fmap (>>= f) w)) +#if !MIN_VERSION_base(4,13,0) + fail e = FreeT (fail e) +#endif + +instance (Applicative f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where + fail e = FreeT (Fail.fail e) + +instance Applicative f => MonadTrans (FreeT f) where + lift = FreeT . liftM Pure + {-# INLINE lift #-} + +instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (Applicative f, MonadReader r m) => MonadReader r (FreeT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFreeT (local f) + {-# INLINE local #-} + +instance (Applicative f, MonadWriter w m) => MonadWriter w (FreeT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Pure x, w) = Pure (x, w) + concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y + pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) + g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance (Applicative f, MonadState s m) => MonadState s (FreeT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance (Applicative f, MonadError e m) => MonadError e (FreeT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f) + +instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where + callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) + +instance (Applicative f, MonadPlus m) => Alternative (FreeT f m) where + empty = FreeT mzero + FreeT ma <|> FreeT mb = FreeT (mplus ma mb) + {-# INLINE (<|>) #-} + +instance (Applicative f, MonadPlus m) => MonadPlus (FreeT f m) where + mzero = FreeT mzero + {-# INLINE mzero #-} + mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb) + {-# INLINE mplus #-} + +instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where + wrap = FreeT . return . Free + {-# INLINE wrap #-} + +instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance (Applicative f, MonadCatch m) => MonadCatch (FreeT f m) where + FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m + `Control.Monad.Catch.catch` (runFreeT . f) + {-# INLINE catch #-} + +-- | Given an applicative homomorphism from @f (m a)@ to @m a@, +-- tear down a free monad transformer using iteration. +iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a +iterT f (FreeT m) = do + val <- m + case fmap (iterT f) val of + Pure x -> return x + Free y -> f y + +-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@, +-- tear down a free monad transformer using iteration over a transformer. +iterTM :: (Applicative f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a +iterTM f (FreeT m) = do + val <- lift m + case fmap (iterTM f) val of + Pure x -> return x + Free y -> f y + +instance (Foldable m, Foldable f) => Foldable (FreeT f m) where + foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m + +instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where + traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m + +-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ +-- +-- @'hoistFreeT' :: ('Functor' m, 'Applicative' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ +hoistFreeT :: (Functor m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b +hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT + +-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ +transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b +transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT + +-- | Pull out and join @m@ layers of @'FreeT' f m a@. +joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a) +joinFreeT (FreeT m) = m >>= joinFreeF + where + joinFreeF (Pure x) = return (return x) + joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f + +-- | +-- 'retract' is the left inverse of 'liftF' +-- +-- @ +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => Free f a -> f a +retract m = + case runIdentity (runFreeT m) of + Pure a -> return a + Free as -> as >>= retract + +-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration. +iter :: Applicative f => (f a -> a) -> Free f a -> a +iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) + +-- | Like 'iter' for monadic values. +iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a +iterM phi = iterT phi . hoistFreeT (return . runIdentity) + +-- | Cuts off a tree of computations at a given depth. +-- If the depth is @0@ or less, no computation nor +-- monadic effects will take place. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'cutoff' 0 _ ≡ 'return' 'Nothing' +-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' +-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' +-- 'cutoff' (n+1) '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('cutoff' n) +-- @ +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Applicative f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a) +cutoff n _ | n <= 0 = return Nothing +cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m + +-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@. +-- This is sort of the opposite for @'cutoff'@. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'partialIterT' 0 _ m ≡ m +-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return' +-- 'partialIterT' (n+1) phi '.' 'lift' ≡ 'lift' +-- 'partialIterT' (n+1) phi '.' 'wrap' ≡ 'join' . 'lift' . phi +-- @ +partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b +partialIterT n phi m + | n <= 0 = m + | otherwise = FreeT $ do + val <- runFreeT m + case val of + Pure a -> return (Pure a) + Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi + +-- | @intersperseT f m@ inserts a layer @f@ between every two layers in +-- @m@. +-- +-- @ +-- 'intersperseT' f '.' 'return' ≡ 'return' +-- 'intersperseT' f '.' 'lift' ≡ 'lift' +-- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap')) +-- @ +intersperseT :: (Monad m, Applicative f) => f a -> FreeT f m b -> FreeT f m b +intersperseT f (FreeT m) = FreeT $ do + val <- m + case val of + Pure x -> return $ Pure x + Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y + +-- | Tear down a free monad transformer using Monad instance for @t m@. +retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a +retractT (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= retractT + +-- | @intercalateT f m@ inserts a layer @f@ between every two layers in +-- @m@ and then retracts the result. +-- +-- @ +-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f +-- @ +intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b +intercalateT f (FreeT m) = do + val <- lift m + case val of + Pure x -> return x + Free y -> y >>= iterTM (\x -> f >> join x) diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs --- a/src/Control/Monad/Trans/Free/Church.hs +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -1,338 +1,295 @@ -{-# 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 --- 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: --- --- --- --- --- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: --- --- -improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a -improve m = fromF m -{-# INLINE improve #-} - --- | Improve the asymptotic performance of code that builds a free monad transformer --- with only binds and returns by using 'FT' behind the scenes. --- --- Similar to 'improve'. -improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a -improveT m = fromFT m -{-# INLINE improveT #-} - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Free.Church +-- Copyright : (C) 2008-2014 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : non-portable (rank-2 polymorphism, MTPCs) +-- +-- Church-encoded free monad transformer. +-- +----------------------------------------------------------------------------- +module Control.Monad.Trans.Free.Church + ( + -- * The free monad transformer + FT(..) + -- * The free monad + , F, free, runF + -- * Operations + , improveT + , toFT, fromFT + , iterT + , iterTM + , hoistFT + , transFT + , joinFT + , cutoff + -- * Operations of free monad + , improve + , fromF, toF + , retract + , retractT + , iter + , iterM + -- * Free Monads With Class + , MonadFree(..) + , liftF + ) where + +import Control.Applicative +import Control.Category ((<<<), (>>>)) +import Control.Monad +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Identity +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class +import Control.Monad.Cont.Class +import Control.Monad.Free.Class +import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free) +import qualified Control.Monad.Trans.Free as FreeT +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Functor.Bind hiding (join) +import Data.Functor.Classes + +-- | The \"free monad transformer\" for a functor @f@ +newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r } + +instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where + liftEq eq x y = liftEq eq (fromFT x) (fromFT y) + +instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where + liftCompare cmp x y= liftCompare cmp (fromFT x) (fromFT y) + +instance (Functor f, Monad m, Eq1 f, Eq1 m, Eq a) => Eq (FT f m a) where + (==) = eq1 + +instance (Functor f, Monad m, Ord1 f, Ord1 m, Ord a) => Ord (FT f m a) where + compare = compare1 + +instance Functor (FT f m) where + fmap f (FT k) = FT $ \a fr -> k (a . f) fr + +instance Apply (FT f m) where + (<.>) = (<*>) + +instance Applicative (FT f m) where + pure a = FT $ \k _ -> k a + FT fk <*> FT ak = FT $ \b fr -> fk (\e -> ak (\d -> b (e d)) fr) fr + +instance Bind (FT f m) where + (>>-) = (>>=) + +instance Monad (FT f m) where + return = pure + FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr + +instance Fail.MonadFail m => Fail.MonadFail (FT f m) where + fail = lift . Fail.fail + {-# INLINE fail #-} + +instance MonadFree f (FT f m) where + wrap f = FT (\kp kf -> kf (\ft -> runFT ft kp kf) f) + +instance MonadTrans (FT f) where + lift m = FT (\a _ -> m >>= a) + +instance Alternative m => Alternative (FT f m) where + empty = FT (\_ _ -> empty) + FT k1 <|> FT k2 = FT $ \a fr -> k1 a fr <|> k2 a fr + +instance MonadPlus m => MonadPlus (FT f m) where + mzero = FT (\_ _ -> mzero) + mplus (FT k1) (FT k2) = FT $ \a fr -> k1 a fr `mplus` k2 a fr + +instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where + foldr f r xs = F.foldr (<<<) id inner r + where + inner = runFT xs (return . f) (\xg xf -> F.foldr (liftM2 (<<<) . xg) (return id) xf) + {-# INLINE foldr #-} + + foldl' f z xs = F.foldl' (!>>>) id inner z + where + (!>>>) h g = \r -> g $! h r + inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf) + {-# INLINE foldl' #-} + +instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where + traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree + where + traversePure = return . fmap return . f + traverseFree xg = return . fmap (wrap . fmap (join . lift)) . T.traverse (T.sequenceA . xg) + +instance (MonadIO m) => MonadIO (FT f m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (Functor f, MonadError e m) => MonadError e (FT f m) where + throwError = lift . throwError + {-# INLINE throwError #-} + m `catchError` f = toFT $ fromFT m `catchError` (fromFT . f) + +instance MonadCont m => MonadCont (FT f m) where + callCC f = join . lift $ callCC (\k -> return $ f (lift . k . return)) + +instance MonadReader r m => MonadReader r (FT f m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistFT (local f) + {-# INLINE local #-} + +instance (Functor f, MonadWriter w m) => MonadWriter w (FT f m) where + tell = lift . tell + {-# INLINE tell #-} + listen = toFT . listen . fromFT + pass = toFT . pass . fromFT + writer w = lift (writer w) + {-# INLINE writer #-} + +instance MonadState s m => MonadState s (FT f m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance MonadThrow m => MonadThrow (FT f m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where + catch m f = toFT $ fromFT m `Control.Monad.Catch.catch` (fromFT . f) + {-# INLINE catch #-} + +-- | Generate a Church-encoded free monad transformer from a 'FreeT' monad +-- transformer. +toFT :: Monad m => FreeT f m a -> FT f m a +toFT (FreeT f) = FT $ \ka kfr -> do + freef <- f + case freef of + Pure a -> ka a + Free fb -> kfr (\x -> runFT (toFT x) ka kfr) fb + +-- | Convert to a 'FreeT' free monad representation. +fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a +fromFT (FT k) = FreeT $ k (return . Pure) (\xg -> runFreeT . wrap . fmap (FreeT . xg)) + +-- | The \"free monad\" for a functor @f@. +type F f = FT f Identity + +-- | Unwrap the 'Free' monad to obtain it's Church-encoded representation. +runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r) +runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (\xg -> return . kf . fmap (runIdentity . xg)) + +-- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor. +free :: (forall r. (a -> r) -> (f r -> r) -> r) -> F f a +free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf return)) + +-- | Tear down a free monad transformer using iteration. +iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a +iterT phi (FT m) = m return (\xg -> phi . fmap xg) +{-# INLINE iterT #-} + +-- | Tear down a free monad transformer using iteration over a transformer. +iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FT f m a -> t m a +iterTM f (FT m) = join . lift $ m (return . return) (\xg -> return . f . fmap (join . lift . xg)) + +-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FT' f m@ to @'FT' f n@ +-- +-- @'hoistFT' :: ('Monad' m, 'Monad' n, 'Functor' f) => (m ~> n) -> 'FT' f m ~> 'FT' f n@ +hoistFT :: (Monad m, Monad n) => (forall a. m a -> n a) -> FT f m b -> FT f n b +hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (\xg -> return . kf (join . phi . xg))) + +-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@ +transFT :: (forall a. f a -> g a) -> FT f m b -> FT g m b +transFT phi (FT m) = FT (\kp kf -> m kp (\xg -> kf xg . phi)) + +-- | Pull out and join @m@ layers of @'FreeT' f m a@. +joinFT :: (Monad m, Traversable f) => FT f m a -> m (F f a) +joinFT (FT m) = m (return . return) (\xg -> liftM wrap . T.mapM xg) + +-- | Cuts off a tree of computations at a given depth. +-- If the depth is 0 or less, no computation nor +-- monadic effects will take place. +-- +-- Some examples (n ≥ 0): +-- +-- prop> cutoff 0 _ == return Nothing +-- prop> cutoff (n+1) . return == return . Just +-- prop> cutoff (n+1) . lift == lift . liftM Just +-- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) +-- +-- Calling 'retract . cutoff n' is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Functor f, Monad m) => Integer -> FT f m a -> FT f m (Maybe a) +cutoff n = toFT . FreeT.cutoff n . fromFT + +-- | +-- 'retract' is the left inverse of 'liftF' +-- +-- @ +-- 'retract' . 'liftF' = 'id' +-- @ +retract :: Monad f => F f a -> f a +retract m = runF m return join +{-# INLINE retract #-} + +-- | Tear down a free monad transformer using iteration over a transformer. +retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a +retractT (FT m) = join . lift $ m (return . return) (\xg xf -> return $ xf >>= join . lift . xg) + +-- | Tear down an 'F' 'Monad' using iteration. +iter :: Functor f => (f a -> a) -> F f a -> a +iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) +{-# INLINE iter #-} + +-- | Like 'iter' for monadic values. +iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> F f a -> m a +iterM phi = iterT phi . hoistFT (return . runIdentity) + +-- | Convert to another free monad representation. +fromF :: (Functor f, MonadFree f m) => F f a -> m a +fromF m = runF m return wrap +{-# INLINE fromF #-} + +-- | Generate a Church-encoded free monad from a 'Free' monad. +toF :: Free f a -> F f a +toF = toFT +{-# INLINE toF #-} + +-- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes. +-- +-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: +-- +-- +-- +-- +-- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: +-- +-- +improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a +improve m = fromF m +{-# INLINE improve #-} + +-- | Improve the asymptotic performance of code that builds a free monad transformer +-- with only binds and returns by using 'FT' behind the scenes. +-- +-- Similar to 'improve'. +improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a +improveT m = fromFT m +{-# INLINE improveT #-} + diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs --- a/src/Control/Monad/Trans/Iter.hs +++ b/src/Control/Monad/Trans/Iter.hs @@ -1,523 +1,435 @@ -{-# 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 --- Stability : provisional --- Portability : MPTCs, fundeps --- --- Based on --- --- Unlike 'Free', this is a true monad transformer. ----------------------------------------------------------------------------- -module Control.Monad.Trans.Iter - ( - -- | - -- Functions in Haskell are meant to be pure. For example, if an expression - -- has type Int, there should exist a value of the type such that the expression - -- can be replaced by that value in any context without changing the meaning - -- of the program. - -- - -- Some computations may perform side effects (@unsafePerformIO@), throw an - -- exception (using @error@); or not terminate - -- (@let infinity = 1 + infinity in infinity@). - -- - -- While the 'IO' monad encapsulates side-effects, and the 'Either' - -- monad encapsulates errors, the 'Iter' monad encapsulates - -- non-termination. The 'IterT' transformer generalizes non-termination to any monadic - -- computation. - -- - -- Computations in 'IterT' (or 'Iter') can be composed in two ways: - -- - -- * /Sequential:/ Using the 'Monad' instance, the result of a computation - -- can be fed into the next. - -- - -- * /Parallel:/ Using the 'MonadPlus' instance, several computations can be - -- executed concurrently, and the first to finish will prevail. - -- See also the . - - -- * The iterative monad transformer - IterT(..) - -- * Capretta's iterative monad - , Iter, iter, runIter - -- * Combinators - , delay - , hoistIterT - , liftIter - , cutoff - , never - , untilJust - , interleave, interleave_ - -- * Consuming iterative monads - , retract - , fold - , foldM - -- * IterT ~ FreeT Identity - , MonadFree(..) - -- * Examples - -- $examples - ) where - -import Control.Applicative -import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) -import Control.Monad (ap, liftM, MonadPlus(..), join) -import Control.Monad.Fix -import Control.Monad.Trans.Class -import qualified Control.Monad.Fail as Fail -import Control.Monad.Free.Class -import Control.Monad.State.Class -import Control.Monad.Error.Class -import Control.Monad.Reader.Class -import Control.Monad.Writer.Class -import Control.Monad.Cont.Class -import Control.Monad.IO.Class -import Data.Bifunctor -import Data.Bitraversable -import Data.Either -import Data.Functor.Bind hiding (join) -import Data.Functor.Classes.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 - -* - -* - --} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Iter +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs, fundeps +-- +-- Based on +-- +-- Unlike 'Free', this is a true monad transformer. +---------------------------------------------------------------------------- +module Control.Monad.Trans.Iter + ( + -- | + -- Functions in Haskell are meant to be pure. For example, if an expression + -- has type Int, there should exist a value of the type such that the expression + -- can be replaced by that value in any context without changing the meaning + -- of the program. + -- + -- Some computations may perform side effects (@unsafePerformIO@), throw an + -- exception (using @error@); or not terminate + -- (@let infinity = 1 + infinity in infinity@). + -- + -- While the 'IO' monad encapsulates side-effects, and the 'Either' + -- monad encapsulates errors, the 'Iter' monad encapsulates + -- non-termination. The 'IterT' transformer generalizes non-termination to any monadic + -- computation. + -- + -- Computations in 'IterT' (or 'Iter') can be composed in two ways: + -- + -- * /Sequential:/ Using the 'Monad' instance, the result of a computation + -- can be fed into the next. + -- + -- * /Parallel:/ Using the 'MonadPlus' instance, several computations can be + -- executed concurrently, and the first to finish will prevail. + -- See also the . + + -- * The iterative monad transformer + IterT(..) + -- * Capretta's iterative monad + , Iter, iter, runIter + -- * Combinators + , delay + , hoistIterT + , liftIter + , cutoff + , never + , untilJust + , interleave, interleave_ + -- * Consuming iterative monads + , retract + , fold + , foldM + -- * IterT ~ FreeT Identity + , MonadFree(..) + -- * Examples + -- $examples + ) where + +import Control.Applicative +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import Control.Monad (ap, liftM, MonadPlus(..), join) +import Control.Monad.Fix +import Control.Monad.Trans.Class +import qualified Control.Monad.Fail as Fail +import Control.Monad.Free.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.Cont.Class +import Control.Monad.IO.Class +import Data.Bifunctor +import Data.Bitraversable +import Data.Either +import Data.Functor.Bind hiding (join) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Typeable +import Data.Data + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif + +-- | The monad supporting iteration based over a base monad @m@. +-- +-- @ +-- 'IterT' ~ 'FreeT' 'Identity' +-- @ +newtype IterT m a = IterT { runIterT :: m (Either a (IterT m a)) } + +-- | Plain iterative computations. +type Iter = IterT Identity + +-- | Builds an iterative computation from one first step. +-- +-- prop> runIter . iter == id +iter :: Either a (Iter a) -> Iter a +iter = IterT . Identity +{-# INLINE iter #-} + +-- | Executes the first step of an iterative computation +-- +-- prop> iter . runIter == id +runIter :: Iter a -> Either a (Iter a) +runIter = runIdentity . runIterT +{-# INLINE runIter #-} + +instance (Eq1 m) => Eq1 (IterT m) where + liftEq eq = go + where + go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y + +instance (Eq1 m, Eq a) => Eq (IterT m a) where + (==) = eq1 + +instance (Ord1 m) => Ord1 (IterT m) where + liftCompare cmp = go + where + go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y + +instance (Ord1 m, Ord a) => Ord (IterT m a) where + compare = compare1 + +instance (Show1 m) => Show1 (IterT m) where + liftShowsPrec sp sl = go + where + goList = liftShowList sp sl + go d (IterT x) = showsUnaryWith + (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList)) + "IterT" d x + +instance (Show1 m, Show a) => Show (IterT m a) where + showsPrec = showsPrec1 + +instance (Read1 m) => Read1 (IterT m) where + liftReadsPrec rp rl = go + where + goList = liftReadList rp rl + go = readsData $ readsUnaryWith + (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList)) + "IterT" IterT + +instance (Read1 m, Read a) => Read (IterT m a) where + readsPrec = readsPrec1 + +instance Monad m => Functor (IterT m) where + fmap f = IterT . liftM (bimap f (fmap f)) . runIterT + {-# INLINE fmap #-} + +instance Monad m => Applicative (IterT m) where + pure = IterT . return . Left + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (IterT m) where + return = pure + {-# INLINE return #-} + IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k)) + {-# INLINE (>>=) #-} +#if !MIN_VERSION_base(4,13,0) + fail = Fail.fail + {-# INLINE fail #-} +#endif + +instance Monad m => Fail.MonadFail (IterT m) where + fail _ = never + {-# INLINE fail #-} + +instance Monad m => Apply (IterT m) where + (<.>) = ap + {-# INLINE (<.>) #-} + +instance Monad m => Bind (IterT m) where + (>>-) = (>>=) + {-# INLINE (>>-) #-} + +instance MonadFix m => MonadFix (IterT m) where + mfix f = IterT $ mfix $ runIterT . f . either id (error "mfix (IterT m): Right") + {-# INLINE mfix #-} + +instance Monad m => Alternative (IterT m) where + empty = mzero + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +-- | Capretta's 'race' combinator. Satisfies left catch. +instance Monad m => MonadPlus (IterT m) where + mzero = never + {-# INLINE mzero #-} + (IterT x) `mplus` (IterT y) = IterT $ x >>= either + (return . Left) + (flip liftM y . second . mplus) + {-# INLINE mplus #-} + +instance MonadTrans IterT where + lift = IterT . liftM Left + {-# INLINE lift #-} + +instance Foldable m => Foldable (IterT m) where + foldMap f = foldMap (either f (foldMap f)) . runIterT + {-# INLINE foldMap #-} + +instance Foldable1 m => Foldable1 (IterT m) where + foldMap1 f = foldMap1 (either f (foldMap1 f)) . runIterT + {-# INLINE foldMap1 #-} + +instance (Monad m, Traversable m) => Traversable (IterT m) where + traverse f (IterT m) = IterT <$> traverse (bitraverse f (traverse f)) m + {-# INLINE traverse #-} + +instance (Monad m, Traversable1 m) => Traversable1 (IterT m) where + traverse1 f (IterT m) = IterT <$> traverse1 go m where + go (Left a) = Left <$> f a + go (Right a) = Right <$> traverse1 f a + {-# INLINE traverse1 #-} + +instance MonadReader e m => MonadReader e (IterT m) where + ask = lift ask + {-# INLINE ask #-} + local f = hoistIterT (local f) + {-# INLINE local #-} + +instance MonadWriter w m => MonadWriter w (IterT m) where + tell = lift . tell + {-# INLINE tell #-} + listen (IterT m) = IterT $ liftM concat' $ listen (fmap listen `liftM` m) + where + concat' (Left x, w) = Left (x, w) + concat' (Right y, w) = Right $ second (w `mappend`) <$> y + pass m = IterT . pass' . runIterT . hoistIterT clean $ listen m + where + clean = pass . liftM (\x -> (x, const mempty)) + pass' = join . liftM g + g (Left ((x, f), w)) = tell (f w) >> return (Left x) + g (Right f) = return . Right . IterT . pass' . runIterT $ f + writer w = lift (writer w) + {-# INLINE writer #-} + +instance MonadState s m => MonadState s (IterT m) where + get = lift get + {-# INLINE get #-} + put s = lift (put s) + {-# INLINE put #-} + state f = lift (state f) + {-# INLINE state #-} + +instance MonadError e m => MonadError e (IterT m) where + throwError = lift . throwError + {-# INLINE throwError #-} + IterT m `catchError` f = IterT $ liftM (fmap (`catchError` f)) m `catchError` (runIterT . f) + +instance MonadIO m => MonadIO (IterT m) where + liftIO = lift . liftIO + +instance MonadCont m => MonadCont (IterT m) where + callCC f = IterT $ callCC (\k -> runIterT $ f (lift . k . Left)) + +instance Monad m => MonadFree Identity (IterT m) where + wrap = IterT . return . Right . runIdentity + {-# INLINE wrap #-} + +instance MonadThrow m => MonadThrow (IterT m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (IterT m) where + catch (IterT m) f = IterT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m `Control.Monad.Catch.catch` (runIterT . f) + {-# INLINE catch #-} + +-- | Adds an extra layer to a free monad value. +-- +-- In particular, for the iterative monad 'Iter', this makes the +-- computation require one more step, without changing its final +-- result. +-- +-- prop> runIter (delay ma) == Right ma +delay :: (Monad f, MonadFree f m) => m a -> m a +delay = wrap . return +{-# INLINE delay #-} + +-- | +-- 'retract' is the left inverse of 'lift' +-- +-- @ +-- 'retract' . 'lift' = 'id' +-- @ +retract :: Monad m => IterT m a -> m a +retract m = runIterT m >>= either return retract + +-- | Tear down a 'Free' 'Monad' using iteration. +fold :: Monad m => (m a -> a) -> IterT m a -> a +fold phi (IterT m) = phi (either id (fold phi) `liftM` m) + +-- | Like 'fold' with monadic result. +foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a +foldM phi (IterT m) = phi (either return (foldM phi) `liftM` m) + +-- | Lift a monad homomorphism from @m@ to @n@ into a Monad homomorphism from @'IterT' m@ to @'IterT' n@. +hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b +hoistIterT f (IterT as) = IterT (fmap (hoistIterT f) `liftM` f as) + +-- | Lifts a plain, non-terminating computation into a richer environment. +-- 'liftIter' is a 'Monad' homomorphism. +liftIter :: (Monad m) => Iter a -> IterT m a +liftIter = hoistIterT (return . runIdentity) + +-- | A computation that never terminates +never :: (Monad f, MonadFree f m) => m a +never = delay never + +-- | Repeatedly run a computation until it produces a 'Just' value. +-- This can be useful when paired with a monad that has side effects. +-- +-- For example, we may have @genId :: IO (Maybe Id)@ that uses a random +-- number generator to allocate ids, but fails if it finds a collision. +-- We can repeatedly run this with +-- +-- @ +-- 'retract' ('untilJust' genId) :: IO Id +-- @ +untilJust :: (Monad m) => m (Maybe a) -> IterT m a +untilJust f = maybe (delay (untilJust f)) return =<< lift f +{-# INLINE untilJust #-} + +-- | Cuts off an iterative computation after a given number of +-- steps. If the number of steps is 0 or less, no computation nor +-- monadic effects will take place. +-- +-- The step where the final value is produced also counts towards the limit. +-- +-- Some examples (@n ≥ 0@): +-- +-- @ +-- 'cutoff' 0 _ ≡ 'return' 'Nothing' +-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' +-- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' +-- 'cutoff' (n+1) '.' 'delay' ≡ 'delay' . 'cutoff' n +-- 'cutoff' n 'never' ≡ 'iterate' 'delay' ('return' 'Nothing') '!!' n +-- @ +-- +-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the +-- steps in the iteration is terminating. +cutoff :: (Monad m) => Integer -> IterT m a -> IterT m (Maybe a) +cutoff n | n <= 0 = const $ return Nothing +cutoff n = IterT . liftM (either (Left . Just) + (Right . cutoff (n - 1))) . runIterT + +-- | Interleaves the steps of a finite list of iterative computations, and +-- collects their results. +-- +-- The resulting computation has as many steps as the longest computation +-- in the list. +interleave :: Monad m => [IterT m a] -> IterT m [a] +interleave ms = IterT $ do + xs <- mapM runIterT ms + if null (rights xs) + then return . Left $ lefts xs + else return . Right . interleave $ map (either return id) xs +{-# INLINE interleave #-} + +-- | Interleaves the steps of a finite list of computations, and discards their +-- results. +-- +-- The resulting computation has as many steps as the longest computation +-- in the list. +-- +-- Equivalent to @'void' '.' 'interleave'@. +interleave_ :: (Monad m) => [IterT m a] -> IterT m () +interleave_ [] = return () +interleave_ xs = IterT $ liftM (Right . interleave_ . rights) $ mapM runIterT xs +{-# INLINE interleave_ #-} + +instance (Monad m, Semigroup a, Monoid a) => Monoid (IterT m a) where + mempty = return mempty + mappend = (<>) + mconcat = mconcat' . map Right + where + mconcat' :: (Monad m, Monoid a) => [Either a (IterT m a)] -> IterT m a + mconcat' ms = IterT $ do + xs <- mapM (either (return . Left) runIterT) ms + case compact xs of + [l@(Left _)] -> return l + xs' -> return . Right $ mconcat' xs' + {-# INLINE mconcat' #-} + + compact :: (Monoid a) => [Either a b] -> [Either a b] + compact [] = [] + compact (r@(Right _):xs) = r:(compact xs) + compact ( Left a :xs) = compact' a xs + + compact' a [] = [Left a] + compact' a (r@(Right _):xs) = (Left a):(r:(compact xs)) + compact' a ( (Left a'):xs) = compact' (a `mappend` a') xs + +instance (Monad m, Semigroup a) => Semigroup (IterT m a) where + x <> y = IterT $ do + x' <- runIterT x + y' <- runIterT y + case (x', y') of + ( Left a, Left b) -> return . Left $ a <> b + ( Left a, Right b) -> return . Right $ liftM (a <>) b + (Right a, Left b) -> return . Right $ liftM (<> b) a + (Right a, Right b) -> return . Right $ a <> b + +deriving instance + ( Typeable m + , Data (m (Either a (IterT m a))) + , Data a + ) => Data (IterT m a) + +{- $examples + +* + +* + +-} diff --git a/src/Data/Functor/Classes/Compat.hs b/src/Data/Functor/Classes/Compat.hs deleted file mode 100644 --- a/src/Data/Functor/Classes/Compat.hs +++ /dev/null @@ -1,45 +0,0 @@ -#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