free-5.2/0000755000000000000000000000000007346545000010472 5ustar0000000000000000free-5.2/.gitignore0000644000000000000000000000043007346545000012457 0ustar0000000000000000dist 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.* free-5.2/.hlint.yaml0000644000000000000000000000053407346545000012554 0ustar0000000000000000- 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} free-5.2/.vim.custom0000644000000000000000000000137707346545000012607 0ustar0000000000000000" 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" free-5.2/CHANGELOG.markdown0000644000000000000000000001640407346545000013532 0ustar00000000000000005.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. free-5.2/LICENSE0000644000000000000000000000266007346545000011503 0ustar0000000000000000Copyright 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. free-5.2/README.markdown0000644000000000000000000000110607346545000013171 0ustar0000000000000000free ==== [![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-5.2/Setup.lhs0000644000000000000000000000016507346545000012304 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain free-5.2/doc/proof/Control/Comonad/Cofree/0000755000000000000000000000000007346545000016567 5ustar0000000000000000free-5.2/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md0000644000000000000000000000033107346545000024352 0ustar0000000000000000Instance of Applicative for Cofree ================================== See [proof for the transformer version] (../Trans/Cofree/instance-Applicative-CofreeT.md) and specialize it for the Identity applicative functor. free-5.2/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md0000644000000000000000000000027707346545000023160 0ustar0000000000000000Instance of Monad for Cofree ================================== See [proof for the transformer version] (../Trans/Cofree/instance-Monad-CofreeT.md) and specialize it for the Identity Monad. free-5.2/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md0000644000000000000000000000057507346545000023644 0ustar0000000000000000MonadZip 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`. free-5.2/doc/proof/Control/Comonad/Trans/Cofree/0000755000000000000000000000000007346545000017656 5ustar0000000000000000free-5.2/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md0000644000000000000000000003437407346545000025603 0ustar0000000000000000Applicative 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) ``` free-5.2/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md0000644000000000000000000001214307346545000024366 0ustar0000000000000000Monad 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). free-5.2/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md0000644000000000000000000000326507346545000025403 0ustar0000000000000000MonadTrans 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) ``` free-5.2/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md0000644000000000000000000003660407346545000025061 0ustar0000000000000000MonadZip 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) . ``` free-5.2/examples/0000755000000000000000000000000007346545000012310 5ustar0000000000000000free-5.2/examples/Cabbage.lhs0000644000000000000000000001461007346545000014326 0ustar0000000000000000> {-# 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) @ free-5.2/examples/LICENSE0000644000000000000000000000266007346545000013321 0ustar0000000000000000Copyright 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. free-5.2/examples/MandelbrotIter.lhs0000644000000000000000000001140407346545000015733 0ustar0000000000000000Compiling 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" free-5.2/examples/NewtonCoiter.lhs0000644000000000000000000000672407346545000015451 0ustar0000000000000000Many 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 free-5.2/examples/PerfTH.hs0000644000000000000000000000666007346545000014004 0ustar0000000000000000{-# 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" free-5.2/examples/RetryTH.hs0000644000000000000000000000526507346545000014215 0ustar0000000000000000{-# 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 free-5.2/examples/Teletype.lhs0000644000000000000000000000764607346545000014630 0ustar0000000000000000> {-# 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. free-5.2/examples/ValidationForm.hs0000644000000000000000000000607707346545000015574 0ustar0000000000000000module 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 ++ "\"!" free-5.2/examples/free-examples.cabal0000644000000000000000000000512007346545000016027 0ustar0000000000000000name: 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 free-5.2/free.cabal0000644000000000000000000000770307346545000012406 0ustar0000000000000000name: 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 free-5.2/src/Control/Alternative/0000755000000000000000000000000007346545000015157 5ustar0000000000000000free-5.2/src/Control/Alternative/Free.hs0000644000000000000000000000665107346545000016404 0ustar0000000000000000{-# 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 #-} free-5.2/src/Control/Alternative/Free/0000755000000000000000000000000007346545000016040 5ustar0000000000000000free-5.2/src/Control/Alternative/Free/Final.hs0000644000000000000000000000421107346545000017423 0ustar0000000000000000{-# 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)) free-5.2/src/Control/Applicative/0000755000000000000000000000000007346545000015142 5ustar0000000000000000free-5.2/src/Control/Applicative/Free.hs0000644000000000000000000002771707346545000016375 0ustar0000000000000000{-# 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 -} free-5.2/src/Control/Applicative/Free/0000755000000000000000000000000007346545000016023 5ustar0000000000000000free-5.2/src/Control/Applicative/Free/Fast.hs0000644000000000000000000001023607346545000017256 0ustar0000000000000000{-# 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 free-5.2/src/Control/Applicative/Free/Final.hs0000644000000000000000000000471407346545000017416 0ustar0000000000000000{-# 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 -} free-5.2/src/Control/Applicative/Trans/0000755000000000000000000000000007346545000016231 5ustar0000000000000000free-5.2/src/Control/Applicative/Trans/Free.hs0000644000000000000000000001462307346545000017454 0ustar0000000000000000{-# 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 free-5.2/src/Control/Comonad/0000755000000000000000000000000007346545000014261 5ustar0000000000000000free-5.2/src/Control/Comonad/Cofree.hs0000644000000000000000000003343507346545000016030 0ustar0000000000000000{-# 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 #-} free-5.2/src/Control/Comonad/Cofree/0000755000000000000000000000000007346545000015464 5ustar0000000000000000free-5.2/src/Control/Comonad/Cofree/Class.hs0000644000000000000000000000342107346545000017065 0ustar0000000000000000{-# 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 free-5.2/src/Control/Comonad/Trans/0000755000000000000000000000000007346545000015350 5ustar0000000000000000free-5.2/src/Control/Comonad/Trans/Cofree.hs0000644000000000000000000001721407346545000017114 0ustar0000000000000000{-# 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 free-5.2/src/Control/Comonad/Trans/Coiter.hs0000644000000000000000000001267607346545000017145 0ustar0000000000000000{-# 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 -} free-5.2/src/Control/Monad/0000755000000000000000000000000007346545000013737 5ustar0000000000000000free-5.2/src/Control/Monad/Free.hs0000644000000000000000000003137307346545000015163 0ustar0000000000000000{-# 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 #-} free-5.2/src/Control/Monad/Free/0000755000000000000000000000000007346545000014620 5ustar0000000000000000free-5.2/src/Control/Monad/Free/Ap.hs0000644000000000000000000002552407346545000015524 0ustar0000000000000000{-# 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 #-} free-5.2/src/Control/Monad/Free/Church.hs0000644000000000000000000002036507346545000016376 0ustar0000000000000000{-# 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) free-5.2/src/Control/Monad/Free/Class.hs0000644000000000000000000001304007346545000016217 0ustar0000000000000000{-# 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 free-5.2/src/Control/Monad/Free/TH.hs0000644000000000000000000004077507346545000015504 0ustar0000000000000000{-# 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) -} free-5.2/src/Control/Monad/Trans/0000755000000000000000000000000007346545000015026 5ustar0000000000000000free-5.2/src/Control/Monad/Trans/Free.hs0000644000000000000000000003463707346545000016260 0ustar0000000000000000{-# 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) free-5.2/src/Control/Monad/Trans/Free/0000755000000000000000000000000007346545000015707 5ustar0000000000000000free-5.2/src/Control/Monad/Trans/Free/Ap.hs0000644000000000000000000003516307346545000016613 0ustar0000000000000000{-# 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) free-5.2/src/Control/Monad/Trans/Free/Church.hs0000644000000000000000000002376607346545000017475 0ustar0000000000000000{-# 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 #-} free-5.2/src/Control/Monad/Trans/Iter.hs0000644000000000000000000003322507346545000016272 0ustar0000000000000000{-# 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 * * -}