free-4.12.4/0000755000000000000000000000000012646574461010730 5ustar0000000000000000free-4.12.4/.ghci0000644000000000000000000000012512646574461011641 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h free-4.12.4/.gitignore0000644000000000000000000000015112646574461012715 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .cabal-sandbox/ cabal.sandbox.config free-4.12.4/.travis.yml0000644000000000000000000000213212646574461013037 0ustar0000000000000000env: - GHCVER=7.4.2 CABALVER=1.18 - GHCVER=7.6.3 CABALVER=1.18 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.2 CABALVER=1.22 - GHCVER=8.0.1 CABALVER=1.24 - GHCVER=head CABALVER=1.24 matrix: allow_failures: - env: GHCVER=head CABALVER=1.24 before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - cabal --version install: - travis_retry cabal update - cabal install --enable-tests --only-dependencies script: - cabal configure -v2 --enable-tests - cabal build - cabal sdist - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313free\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" free-4.12.4/.vim.custom0000644000000000000000000000137712646574461013045 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-4.12.4/CHANGELOG.markdown0000644000000000000000000000711712646574461013771 0ustar00000000000000004.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-4.12.4/free.cabal0000644000000000000000000000625312646574461012643 0ustar0000000000000000name: free category: Control, Monads version: 4.12.4 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/free/ bug-reports: http://github.com/ekmett/free/issues copyright: Copyright (C) 2008-2015 Edward A. Kmett tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.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: .ghci .gitignore .travis.yml .vim.custom README.markdown CHANGELOG.markdown HLint.hs doc/proof/Control/Comonad/Cofree/*.md doc/proof/Control/Comonad/Trans/Cofree/*.md 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 default-extensions: CPP other-extensions: MultiParamTypeClasses FunctionalDependencies FlexibleInstances UndecidableInstances Rank2Types GADTs build-depends: base == 4.*, bifunctors >= 4 && < 6, comonad >= 4 && < 6, distributive >= 0.2.1, mtl >= 2.0.1.0 && < 2.3, prelude-extras >= 0.4 && < 1, profunctors >= 4 && < 6, semigroupoids >= 4 && < 6, semigroups >= 0.8.3.1 && < 1, transformers >= 0.2.0 && < 0.6, transformers-compat >= 0.3 && < 1, template-haskell >= 2.7.0.0 && < 3, exceptions >= 0.6 && < 0.9, containers < 0.6 exposed-modules: Control.Applicative.Free 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.Church Control.Monad.Free.Class Control.Monad.Free.TH Control.Monad.Trans.Free Control.Monad.Trans.Free.Church Control.Monad.Trans.Iter ghc-options: -Wall free-4.12.4/HLint.hs0000644000000000000000000000040512646574461012301 0ustar0000000000000000import "hint" HLint.HLint infixr 5 :< -- This affects performance ignore "Redundant lambda" -- This is not valid for improve ignore "Eta reduce" -- DeriveDataTypable noise ignore "Unused LANGUAGE pragma" -- They are clearer in places ignore "Avoid lambda" free-4.12.4/LICENSE0000644000000000000000000000266012646574461011741 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-4.12.4/README.markdown0000644000000000000000000000104112646574461013425 0ustar0000000000000000free ==== [![Hackage](https://img.shields.io/hackage/v/free.svg)](https://hackage.haskell.org/package/free) [![Build Status](https://secure.travis-ci.org/ekmett/free.png?branch=master)](http://travis-ci.org/ekmett/free) 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-4.12.4/Setup.lhs0000644000000000000000000000016512646574461012542 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain free-4.12.4/doc/0000755000000000000000000000000012646574461011475 5ustar0000000000000000free-4.12.4/doc/proof/0000755000000000000000000000000012646574461012622 5ustar0000000000000000free-4.12.4/doc/proof/Control/0000755000000000000000000000000012646574461014242 5ustar0000000000000000free-4.12.4/doc/proof/Control/Comonad/0000755000000000000000000000000012646574461015622 5ustar0000000000000000free-4.12.4/doc/proof/Control/Comonad/Cofree/0000755000000000000000000000000012646574461017025 5ustar0000000000000000free-4.12.4/doc/proof/Control/Comonad/Cofree/instance-Applicative-Cofree.md0000644000000000000000000000033112646574461024610 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-4.12.4/doc/proof/Control/Comonad/Cofree/instance-Monad-Cofree.md0000644000000000000000000000027712646574461023416 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-4.12.4/doc/proof/Control/Comonad/Cofree/instance-MonadZip-Cofree.md0000644000000000000000000000057512646574461024102 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-4.12.4/doc/proof/Control/Comonad/Trans/0000755000000000000000000000000012646574461016711 5ustar0000000000000000free-4.12.4/doc/proof/Control/Comonad/Trans/Cofree/0000755000000000000000000000000012646574461020114 5ustar0000000000000000free-4.12.4/doc/proof/Control/Comonad/Trans/Cofree/instance-Applicative-CofreeT.md0000644000000000000000000003437412646574461026041 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 repeteadly 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 repeteadly 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-4.12.4/doc/proof/Control/Comonad/Trans/Cofree/instance-Monad-CofreeT.md0000644000000000000000000001214212646574461024623 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 abreviated 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-4.12.4/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadTrans-CofreeT.md0000644000000000000000000000326512646574461025641 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-4.12.4/doc/proof/Control/Comonad/Trans/Cofree/instance-MonadZip-CofreeT.md0000644000000000000000000003660412646574461025317 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-4.12.4/examples/0000755000000000000000000000000012646574461012546 5ustar0000000000000000free-4.12.4/examples/Cabbage.lhs0000644000000000000000000001464512646574461014574 0ustar0000000000000000> {-# LANGUAGE ViewPatterns #-} > module Cabbage where > import Control.Applicative > 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 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-4.12.4/examples/MandelbrotIter.lhs0000644000000000000000000001143512646574461016175 0ustar0000000000000000Compiling to an executable file with the @-O2@ optimization level is recomended. For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@ > {-# LANGUAGE PackageImports #-} > import Control.Arrow > import Control.Monad.Trans.Iter > import "mtl" Control.Monad.Reader > import "mtl" Control.Monad.List > import "mtl" Control.Monad.Identity > import Control.Monad.IO.Class > import Data.Complex > import Graphics.HGL (runGraphics, Window, withPen, > line, RGB (RGB), RedrawMode (Unbuffered, 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 p@(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-4.12.4/examples/NewtonCoiter.lhs0000644000000000000000000000666012646574461015706 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 #-} > import Control.Comonad.Trans.Coiter > import Control.Comonad.Env > import Control.Applicative > 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:a':_ = toList 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-4.12.4/examples/RetryTH.hs0000644000000000000000000000504412646574461014446 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} module Main where import Control.Monad import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.IO.Class 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 :: MonadIO m => Retry a -> m a runRetry = iterM run where run :: 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 "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 "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-4.12.4/examples/Teletype.lhs0000644000000000000000000000765412646574461015065 0ustar0000000000000000> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- > import Control.Monad (mfilter) > import Control.Monad.Loops (unfoldM) > import Control.Monad.Free (liftF, Free, iterM, MonadFree) > import Control.Monad.Free.TH (makeFree) > import Control.Applicative ((<$>)) > import System.IO (isEOF) > import Control.Exception (catch) > 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) = 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-4.12.4/examples/ValidationForm.hs0000644000000000000000000000577612646574461016037 0ustar0000000000000000module Main where import Control.Applicative import Control.Applicative.Free import Control.Monad.State import Data.Monoid 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 :: Integer) where 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-4.12.4/src/0000755000000000000000000000000012646574461011517 5ustar0000000000000000free-4.12.4/src/Control/0000755000000000000000000000000012646574461013137 5ustar0000000000000000free-4.12.4/src/Control/Alternative/0000755000000000000000000000000012646574461015415 5ustar0000000000000000free-4.12.4/src/Control/Alternative/Free.hs0000644000000000000000000001066212646574461016637 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Alternative.Free -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, Rank2Types -- -- Left distributive 'Alternative' functors for free, based on a design -- by Stijn van Drongelen. ---------------------------------------------------------------------------- module Control.Alternative.Free ( Alt(..) , AltF(..) , runAlt , liftAlt , hoistAlt ) where import Control.Applicative import Data.Functor.Apply import Data.Functor.Alt (()) import qualified Data.Functor.Alt as Alt import Data.Semigroup import Data.Typeable infixl 3 `Ap` data AltF f a where Ap :: f a -> Alt f (a -> b) -> AltF f b Pure :: a -> AltF f a #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif newtype Alt f a = Alt { alternatives :: [AltF f a] } #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif instance Functor f => Functor (AltF f) where fmap f (Pure a) = Pure $ f a fmap f (Ap x g) = x `Ap` fmap (f .) g instance Functor f => Functor (Alt f) where fmap f (Alt xs) = Alt $ map (fmap f) xs instance Functor f => 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 Functor f => 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 :: (Functor f) => f a -> AltF f a liftAltF x = x `Ap` pure id {-# INLINE liftAltF #-} -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftAlt :: (Functor f) => 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 (Functor f) => Apply (Alt f) where (<.>) = (<*>) {-# INLINE (<.>) #-} instance (Functor f) => Alt.Alt (Alt f) where () = (<|>) {-# INLINE () #-} instance (Functor f) => Alternative (Alt f) where empty = Alt [] {-# INLINE empty #-} Alt as <|> Alt bs = Alt (as ++ bs) {-# INLINE (<|>) #-} instance (Functor f) => Semigroup (Alt f a) where (<>) = (<|>) {-# INLINE (<>) #-} instance (Functor f) => Monoid (Alt f a) where mempty = empty {-# INLINE mempty #-} mappend = (<|>) {-# INLINE mappend #-} mconcat as = Alt (as >>= alternatives) {-# INLINE mconcat #-} hoistAltF :: (forall a. f a -> g a) -> AltF f b -> AltF g b hoistAltF _ (Pure a) = Pure a hoistAltF f (Ap x y) = Ap (f x) (hoistAlt f y) {-# INLINE hoistAltF #-} -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@. hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b hoistAlt f (Alt as) = Alt (map (hoistAltF f) as) {-# INLINE hoistAlt #-} #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Alt f) where typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where f :: Alt f a -> f a f = undefined instance Typeable1 f => Typeable1 (AltF f) where typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where f :: AltF f a -> f a f = undefined altTyCon, altFTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 altTyCon = mkTyCon "Control.Alternative.Free.Alt" altFTyCon = mkTyCon "Control.Alternative.Free.AltF" #else altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt" altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF" #endif {-# NOINLINE altTyCon #-} {-# NOINLINE altFTyCon #-} #endif free-4.12.4/src/Control/Alternative/Free/0000755000000000000000000000000012646574461016276 5ustar0000000000000000free-4.12.4/src/Control/Alternative/Free/Final.hs0000644000000000000000000000375612646574461017676 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- 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 import Data.Semigroup -- | The free 'Alternative' for a 'Functor' @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) 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-4.12.4/src/Control/Applicative/0000755000000000000000000000000012646574461015400 5ustar0000000000000000free-4.12.4/src/Control/Applicative/Free.hs0000644000000000000000000000670512646574461016625 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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 , hoistAp , retractAp -- * Examples -- $examples ) where import Control.Applicative import Data.Functor.Apply import Data.Typeable #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where Pure :: a -> Ap f a Ap :: f a -> Ap f (a -> b) -> Ap f b #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. -- -- prop> runAp t == retractApp . hoistApp t runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a runAp _ (Pure x) = pure x runAp u (Ap f x) = flip id <$> u f <*> runAp u x -- | Perform a monoidal analysis over free applicative value. -- -- Example: -- -- @ -- count :: Ap f a -> Int -- count = getSum . runAp_ (\\_ -> Sum 1) -- @ runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m runAp_ f = getConst . runAp (Const . f) instance Functor (Ap f) where fmap f (Pure a) = Pure (f a) fmap f (Ap x y) = Ap x ((f .) <$> y) instance Apply (Ap f) where Pure f <.> y = fmap f y Ap x y <.> z = Ap x (flip <$> y <.> z) instance Applicative (Ap f) where pure = Pure Pure f <*> y = fmap f y Ap x y <*> z = Ap x (flip <$> y <*> z) -- | 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 #-} -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b hoistAp _ (Pure a) = Pure a hoistAp f (Ap x y) = Ap (f x) (hoistAp f y) -- | Interprets the free applicative functor over f using the semantics for -- `pure` and `<*>` given by the Applicative instance for f. -- -- prop> retractApp == runAp id retractAp :: Applicative f => Ap f a -> f a retractAp (Pure a) = pure a retractAp (Ap x y) = x <**> retractAp y #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Ap f) where typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where f :: Ap f a -> f a f = undefined apTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 apTyCon = mkTyCon "Control.Applicative.Free.Ap" #else apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap" #endif {-# NOINLINE apTyCon #-} #endif {- $examples -} free-4.12.4/src/Control/Applicative/Free/0000755000000000000000000000000012646574461016261 5ustar0000000000000000free-4.12.4/src/Control/Applicative/Free/Final.hs0000644000000000000000000000510712646574461017651 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Free.Final -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, Rank2Types -- -- Final encoding of free 'Applicative' functors. ---------------------------------------------------------------------------- module Control.Applicative.Free.Final ( -- | Compared to the free monad, they are less expressive. However, they are also more -- flexible to inspect and interpret, as the number of ways in which -- the values can be nested is more limited. Ap(..) , runAp , runAp_ , liftAp , hoistAp , retractAp -- * Examples -- $examples ) where import Control.Applicative import Data.Functor.Apply #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif -- | The free 'Applicative' for a 'Functor' @f@. newtype Ap f a = Ap { _runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a } -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. -- -- prop> runAp t == retractApp . hoistApp t runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a runAp phi m = _runAp m phi -- | Perform a monoidal analysis over free applicative value. -- -- Example: -- -- @ -- count :: Ap f a -> Int -- count = getSum . runAp_ (\\_ -> Sum 1) -- @ runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m runAp_ f = getConst . runAp (Const . f) instance Functor (Ap f) where fmap f (Ap g) = Ap (\k -> fmap f (g k)) instance Apply (Ap f) where Ap f <.> Ap x = Ap (\k -> f k <*> x k) instance Applicative (Ap f) where pure x = Ap (\_ -> pure x) Ap f <*> Ap x = Ap (\k -> f k <*> x k) -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftAp :: f a -> Ap f a liftAp x = Ap (\k -> k x) -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b hoistAp f (Ap g) = Ap (\k -> g (k . f)) -- | Interprets the free applicative functor over f using the semantics for -- `pure` and `<*>` given by the Applicative instance for f. -- -- prop> retractApp == runAp id retractAp :: Applicative f => Ap f a -> f a retractAp (Ap g) = g id {- $examples -} free-4.12.4/src/Control/Applicative/Trans/0000755000000000000000000000000012646574461016467 5ustar0000000000000000free-4.12.4/src/Control/Applicative/Trans/Free.hs0000644000000000000000000001673112646574461017714 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Trans.Free -- Copyright : (C) 2012-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, Rank2Types -- -- 'Applicative' functor transformers for free ---------------------------------------------------------------------------- module Control.Applicative.Trans.Free ( -- | Compared to the free monad transformers, they are less expressive. However, they are also more -- flexible to inspect and interpret, as the number of ways in which -- the values can be nested is more limited. -- -- See , -- by Paolo Capriotti and Ambrus Kaposi, for some applications. ApT(..) , ApF(..) , liftApT , liftApO , runApT , runApF , runApT_ , hoistApT , hoistApF , transApT , transApF , joinApT -- * Free Applicative , Ap , runAp , runAp_ , retractAp -- * Free Alternative , Alt , runAlt ) where import Control.Applicative import Control.Monad (liftM) import Data.Functor.Apply import Data.Functor.Identity import Data.Typeable #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid) #endif import qualified Data.Foldable as F -- | The free 'Applicative' for a 'Functor' @f@. data ApF f g a where Pure :: a -> ApF f g a Ap :: f a -> ApT f g (a -> b) -> ApF f g b #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif -- | The free 'Applicative' transformer for a 'Functor' @f@ over -- 'Applicative' @g@. newtype ApT f g a = ApT { getApT :: g (ApF f g a) } #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif instance Functor g => Functor (ApF f g) where fmap f (Pure a) = Pure (f a) fmap f (Ap x g) = x `Ap` fmap (f .) g instance Functor g => Functor (ApT f g) where fmap f (ApT g) = ApT (fmap f <$> g) instance Applicative g => Applicative (ApF f g) where pure = Pure {-# INLINE pure #-} Pure f <*> y = fmap f y -- fmap y <*> Pure a = fmap ($ a) y -- interchange Ap a f <*> b = a `Ap` (flip <$> f <*> ApT (pure b)) {-# INLINE (<*>) #-} instance Applicative g => Applicative (ApT f g) where pure = ApT . pure . pure {-# INLINE pure #-} ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys) {-# INLINE (<*>) #-} instance Applicative g => Apply (ApF f g) where (<.>) = (<*>) {-# INLINE (<.>) #-} instance Applicative g => Apply (ApT f g) where (<.>) = (<*>) {-# INLINE (<.>) #-} instance Alternative g => Alternative (ApT f g) where empty = ApT empty {-# INLINE empty #-} ApT g <|> ApT h = ApT (g <|> h) {-# INLINE (<|>) #-} -- | A version of 'lift' that can be used with no constraint for @f@. liftApT :: Applicative g => f a -> ApT f g a liftApT x = ApT (pure (Ap x (pure id))) -- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@. liftApO :: Functor g => g a -> ApT f g a liftApO g = ApT (Pure <$> g) -- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives -- a natural transformation @ApF f g ~> h@. runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b runApF _ _ (Pure x) = pure x runApF f g (Ap x y) = f x <**> runApT f g y -- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives -- a natural transformation @ApT f g ~> h@. runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b runApT f g (ApT a) = g (runApF f g <$> a) -- | Perform a monoidal analysis over @'ApT' f g b@ value. -- -- Examples: -- -- @ -- height :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int' -- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum' -- @ -- -- @ -- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int' -- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.fold' -- @ runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst) -- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@. hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b hoistApF _ (Pure x) = Pure x hoistApF f (Ap x y) = f x `Ap` hoistApT f y -- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@. hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b hoistApT f (ApT g) = ApT (hoistApF f <$> g) -- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@. transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b transApF _ (Pure x) = Pure x transApF f (Ap x y) = x `Ap` transApT f y -- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@. transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b transApT f (ApT g) = ApT $ f (transApF f <$> g) -- | Pull out and join @m@ layers of @'ApT' f m a@. joinApT :: Monad m => ApT f m a -> m (Ap f a) joinApT (ApT m) = m >>= joinApF where joinApF (Pure x) = return (pure x) joinApF (Ap x y) = (liftApT x <**>) `liftM` joinApT y -- | The free 'Applicative' for a 'Functor' @f@. type Ap f = ApT f Identity -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. -- -- prop> runAp t == retractApp . hoistApp t runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a runAp f = runApT f runIdentity -- | Perform a monoidal analysis over free applicative value. -- -- Example: -- -- @ -- count :: 'Ap' f a -> 'Int' -- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1) -- @ runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m runAp_ f = runApT_ f runIdentity -- | Interprets the free applicative functor over f using the semantics for -- `pure` and `<*>` given by the Applicative instance for f. -- -- prop> retractApp == runAp id retractAp :: Applicative f => Ap f a -> f a retractAp = runAp id -- | The free 'Alternative' for a 'Functor' @f@. type Alt f = ApT f [] -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. runAlt :: (Alternative g, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs where h (Pure x) = pure x h (Ap x g) = f x <**> runAlt f g #if __GLASGOW_HASKELL__ < 707 instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where f :: ApT f g a -> g (f a) f = undefined instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where f :: ApF f g a -> g (f a) f = undefined apTTyCon, apFTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT" apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF" #else apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT" apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF" #endif {-# NOINLINE apTTyCon #-} {-# NOINLINE apFTyCon #-} #endif free-4.12.4/src/Control/Comonad/0000755000000000000000000000000012646574461014517 5ustar0000000000000000free-4.12.4/src/Control/Comonad/Cofree.hs0000644000000000000000000002765612646574461016276 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- 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 ) 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.Extend import Data.Data import Data.Distributive import Data.Foldable import Data.Semigroup import Data.Traversable import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (id,(.)) import Prelude.Extras 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 a comonad for a non-empty list. -- -- * @'Cofree' ('Const' b)@ is a product. -- -- * @'Cofree' 'Identity'@ forms an infinite stream. -- -- * @'Cofree' ((->) b)'@ describes a Moore machine with states labeled with values of type a, and transitions on edges of type b. -- -- Furthermore, if the functor @f@ forms a monoid (for example, by -- being an instance of 'Alternative'), the resulting 'Comonad' is -- also a 'Monad'. See -- by Neil Ghani et al., Section 4.3 -- for more details. -- -- In particular, if @f a ≡ [a]@, the -- resulting data structure is a . -- For a practical application, check -- by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a) #if __GLASGOW_HASKELL__ >= 707 deriving (Typeable) #endif -- | Use coiteration to generate a cofree comonad from a seed. -- -- @'coiter' f = 'unfold' ('id' 'Control.Arrow.&&&' f)@ coiter :: Functor f => (a -> f a) -> a -> Cofree f a coiter psi a = a :< (coiter psi <$> psi a) -- | Like coiter for comonadic values. coiterW :: (Comonad w, Functor f) => (w a -> f (w a)) -> w a -> Cofree f a coiterW psi a = extract a :< (coiterW psi <$> psi a) -- | Unfold a cofree comonad from a seed. unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a unfold f c = case f c of (x, d) -> x :< fmap (unfold f) d -- | Unfold a cofree comonad from a seed, monadically. unfoldM :: (Traversable f, Monad m) => (b -> m (a, f b)) -> b -> m (Cofree f a) unfoldM f = f >=> \ (x, t) -> (x :<) `liftM` Data.Traversable.mapM (unfoldM f) t hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y) instance Functor f => ComonadCofree f (Cofree f) where unwrap (_ :< as) = as {-# INLINE unwrap #-} instance Distributive f => Distributive (Cofree f) where distribute w = fmap extract w :< fmap distribute (collect unwrap w) instance Functor f => Functor (Cofree f) where fmap f (a :< as) = f a :< fmap (fmap f) as b <$ (_ :< as) = b :< fmap (b <$) as instance Functor f => Extend (Cofree f) where extended = extend {-# INLINE extended #-} duplicated = duplicate {-# INLINE duplicated #-} instance Functor f => Comonad (Cofree f) where extend f w = f w :< fmap (extend f) (unwrap w) duplicate w = w :< fmap duplicate (unwrap w) extract (a :< _) = a {-# INLINE extract #-} -- | This is not a true 'Comonad' transformer, but this instance is convenient. instance ComonadTrans Cofree where lower (_ :< as) = fmap extract as {-# INLINE lower #-} instance Alternative f => Monad (Cofree f) where return = pure {-# INLINE return #-} (a :< m) >>= k = case k a of b :< n -> b :< (n <|> fmap (>>= k) m) instance (Alternative f, MonadZip f) => MonadZip (Cofree f) where mzip (a :< as) (b :< bs) = (a, b) :< fmap (uncurry mzip) (mzip as bs) -- | -- -- @'lower' . 'section' = 'id'@ section :: Comonad f => f a -> Cofree f a section as = extract as :< extend section as instance Apply f => Apply (Cofree f) where (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as) {-# INLINE (<.>) #-} (f :< fs) <. (_ :< as) = f :< ((<. ) <$> fs <.> as) {-# INLINE (<.) #-} (_ :< fs) .> (a :< as) = a :< (( .>) <$> fs <.> as) {-# INLINE (.>) #-} instance ComonadApply f => ComonadApply (Cofree f) where (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as) {-# INLINE (<@>) #-} (f :< fs) <@ (_ :< as) = f :< ((<@ ) <$> fs <@> as) {-# INLINE (<@) #-} (_ :< fs) @> (a :< as) = a :< (( @>) <$> fs <@> as) {-# INLINE (@>) #-} instance Alternative f => Applicative (Cofree f) where pure x = x :< empty {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} instance (Functor f, Show1 f) => Show1 (Cofree f) where showsPrec1 d (a :< as) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as) instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where showsPrec d (a :< as) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 as instance (Functor f, Read1 f) => Read1 (Cofree f) where readsPrec1 d r = readParen (d > 5) (\r' -> [(u :< fmap lower1 v,w) | (u, s) <- readsPrec 6 r', (":<", t) <- lex s, (v, w) <- readsPrec1 5 t]) r instance (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where readsPrec d r = readParen (d > 5) (\r' -> [(u :< v,w) | (u, s) <- readsPrec 6 r', (":<", t) <- lex s, (v, w) <- readsPrec 5 t]) r instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where #ifndef HLINT a :< as == b :< bs = a == b && as == bs #endif instance (Functor f, Eq1 f) => Eq1 (Cofree f) where #ifndef HLINT a :< as ==# b :< bs = a == b && fmap Lift1 as ==# fmap Lift1 bs #endif instance (Ord (f (Cofree f a)), Ord a) => Ord (Cofree f a) where compare (a :< as) (b :< bs) = case compare a b of LT -> LT EQ -> compare as bs GT -> GT instance (Functor f, Ord1 f) => Ord1 (Cofree f) where compare1 (a :< as) (b :< bs) = case compare a b of LT -> LT EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs) GT -> GT instance Foldable f => Foldable (Cofree f) where foldMap f = go where go (a :< as) = f a `mappend` foldMap go as {-# INLINE foldMap #-} #if __GLASGOW_HASKELL__ >= 709 length = go 0 where go s (_ :< as) = foldl' go (s + 1) as #endif instance Foldable1 f => Foldable1 (Cofree f) where foldMap1 f = go where go (a :< as) = f a <> foldMap1 go as {-# INLINE foldMap1 #-} instance Traversable f => Traversable (Cofree f) where traverse f = go where go (a :< as) = (:<) <$> f a <*> traverse go as {-# INLINE traverse #-} instance Traversable1 f => Traversable1 (Cofree f) where traverse1 f = go where go (a :< as) = (:<) <$> f a <.> traverse1 go as {-# INLINE traverse1 #-} #if __GLASGOW_HASKELL__ < 707 instance (Typeable1 f) => Typeable1 (Cofree f) where typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)] where f :: Cofree f a -> f a f = undefined instance (Typeable1 f, Typeable a) => Typeable (Cofree f a) where typeOf = typeOfDefault cofreeTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 cofreeTyCon = mkTyCon "Control.Comonad.Cofree.Cofree" #else cofreeTyCon = mkTyCon3 "free" "Control.Comonad.Cofree" "Cofree" #endif {-# NOINLINE cofreeTyCon #-} instance ( Typeable1 f , Data (f (Cofree f a)) , Data a ) => Data (Cofree f a) where gfoldl f z (a :< as) = z (:<) `f` a `f` as toConstr _ = cofreeConstr gunfold k z c = case constrIndex c of 1 -> k (k (z (:<))) _ -> error "gunfold" dataTypeOf _ = cofreeDataType dataCast1 f = gcast1 f cofreeConstr :: Constr cofreeConstr = mkConstr cofreeDataType ":<" [] Infix {-# NOINLINE cofreeConstr #-} cofreeDataType :: DataType cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr] {-# NOINLINE cofreeDataType #-} #endif instance ComonadHoist Cofree where cohoist = hoistCofree instance ComonadEnv e w => ComonadEnv e (Cofree w) where ask = ask . lower {-# INLINE ask #-} instance ComonadStore s w => ComonadStore s (Cofree w) where pos (_ :< as) = Class.pos as {-# INLINE pos #-} peek s (_ :< as) = extract (Class.peek s as) {-# INLINE peek #-} instance ComonadTraced m w => ComonadTraced m (Cofree w) where trace m = trace m . lower {-# INLINE trace #-} -- | This is a lens that can be used to read or write from the target of 'extract'. -- -- Using (^.) from the @lens@ package: -- -- @foo ^. '_extract' == 'extract' foo@ -- -- For more on lenses see the @lens@ package on hackage -- -- @'_extract' :: Lens' ('Cofree' g a) a@ _extract :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a) _extract f (a :< as) = (:< as) <$> f a {-# INLINE _extract #-} -- | This is a lens that can be used to read or write to the tails of a 'Cofree' 'Comonad'. -- -- Using (^.) from the @lens@ package: -- -- @foo ^. '_unwrap' == 'unwrap' foo@ -- -- For more on lenses see the @lens@ package on hackage -- -- @'_unwrap' :: Lens' ('Cofree' g a) (g ('Cofree' g a))@ _unwrap :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a) _unwrap f (a :< as) = (a :<) <$> f as {-# INLINE _unwrap #-} -- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor. -- When the input list is empty, this is equivalent to '_extract'. -- When the input list is non-empty, this composes the input lenses -- with '_unwrap' to walk through the @'Cofree' g@ before using -- '_extract' to get the element at the final location. -- -- For more on lenses see the 'lens' package on hackage. -- -- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)] -> Lens' ('Cofree' g a) a@ -- -- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) a@ -- -- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)] -> Getter ('Cofree' g a) a@ -- -- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)] -> Fold ('Cofree' g a) a@ -- -- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)] -> Setter' ('Cofree' g a) a@ telescoped :: Functor f => [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] -> (a -> f a) -> Cofree g a -> f (Cofree g a) telescoped = Prelude.foldr (\l r -> _unwrap . l . r) _extract {-# INLINE telescoped #-} free-4.12.4/src/Control/Comonad/Cofree/0000755000000000000000000000000012646574461015722 5ustar0000000000000000free-4.12.4/src/Control/Comonad/Cofree/Class.hs0000644000000000000000000000347012646574461017327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# 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 import Data.Tree #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif -- | Allows you to peel a layer off a cofree comonad. class (Functor f, Comonad w) => ComonadCofree f w | w -> f where -- | Remove a layer. unwrap :: w a -> f (w a) instance ComonadCofree Maybe NonEmpty where unwrap (_ :| []) = Nothing unwrap (_ :| (a : as)) = Just (a :| as) instance ComonadCofree [] Tree where unwrap = subForest instance ComonadCofree (Const b) ((,) b) where unwrap = Const . fst instance ComonadCofree f w => ComonadCofree f (IdentityT w) where unwrap = fmap IdentityT . unwrap . runIdentityT instance ComonadCofree f w => ComonadCofree f (EnvT e w) where unwrap (EnvT e wa) = EnvT e <$> unwrap wa instance ComonadCofree f w => ComonadCofree f (StoreT s w) where unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa instance (ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where unwrap (TracedT wma) = TracedT <$> unwrap wma free-4.12.4/src/Control/Comonad/Trans/0000755000000000000000000000000012646574461015606 5ustar0000000000000000free-4.12.4/src/Control/Comonad/Trans/Cofree.hs0000644000000000000000000002104712646574461017351 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- 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.Identity import Data.Semigroup import Data.Traversable import Control.Monad (liftM) import Control.Monad.Trans import Control.Monad.Zip import Prelude hiding (id,(.)) import Data.Data infixr 5 :< -- | This is the base functor of the cofree comonad transformer. data CofreeF f a b = a :< f b deriving (Eq,Ord,Show,Read #if __GLASGOW_HASKELL__ >= 707 ,Typeable #endif ) -- | Extract the head of the base functor headF :: CofreeF f a b -> a headF (a :< _) = a -- | Extract the tails of the base functor tailF :: CofreeF f a b -> f b tailF (_ :< as) = as instance Functor f => Functor (CofreeF f a) where fmap f (a :< as) = a :< fmap f as instance Foldable f => Foldable (CofreeF f a) where foldMap f (_ :< as) = foldMap f as instance Traversable f => Traversable (CofreeF f a) where traverse f (a :< as) = (a :<) <$> traverse f as instance Functor f => Bifunctor (CofreeF f) where bimap f g (a :< as) = f a :< fmap g as instance Foldable f => Bifoldable (CofreeF f) where bifoldMap f g (a :< as) = f a `mappend` foldMap g as instance Traversable f => Bitraversable (CofreeF f) where bitraverse f g (a :< as) = (:<) <$> f a <*> traverse g as transCofreeF :: (forall x. f x -> g x) -> CofreeF f a b -> CofreeF g a b transCofreeF t (a :< fb) = a :< t fb {-# INLINE transCofreeF #-} -- | This is a cofree comonad of some functor @f@, with a comonad @w@ threaded through it at each level. newtype CofreeT f w a = CofreeT { runCofreeT :: w (CofreeF f a (CofreeT f w a)) } #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif -- | The cofree `Comonad` of a functor @f@. type Cofree f = CofreeT f Identity {- | Wrap another layer around a cofree comonad value. @cofree@ is a right inverse of `runCofree`. @ runCofree . cofree == id @ -} cofree :: CofreeF f a (Cofree f a) -> Cofree f a cofree = CofreeT . Identity {-# INLINE cofree #-} {- | Unpeel the first layer off a cofree comonad value. @runCofree@ is a right inverse of `cofree`. @ cofree . runCofree == id @ -} runCofree :: Cofree f a -> CofreeF f a (Cofree f a) runCofree = runIdentity . runCofreeT {-# INLINE runCofree #-} instance (Functor f, Functor w) => Functor (CofreeT f w) where fmap f = CofreeT . fmap (bimap f (fmap f)) . runCofreeT instance (Functor f, Comonad w) => Comonad (CofreeT f w) where extract = headF . extract . runCofreeT extend f = CofreeT . extend (\w -> f (CofreeT w) :< (extend f <$> tailF (extract w))) . runCofreeT instance (Foldable f, Foldable w) => Foldable (CofreeT f w) where foldMap f = foldMap (bifoldMap f (foldMap f)) . runCofreeT instance (Traversable f, Traversable w) => Traversable (CofreeT f w) where traverse f = fmap CofreeT . traverse (bitraverse f (traverse f)) . runCofreeT instance ComonadTrans (CofreeT f) where lower = fmap headF . runCofreeT instance (Functor f, Comonad w) => ComonadCofree f (CofreeT f w) where unwrap = tailF . extract . runCofreeT instance (Functor f, ComonadEnv e w) => ComonadEnv e (CofreeT f w) where ask = ask . lower {-# INLINE ask #-} instance Functor f => ComonadHoist (CofreeT f) where cohoist g = CofreeT . fmap (second (cohoist g)) . g . runCofreeT instance Show (w (CofreeF f a (CofreeT f w a))) => Show (CofreeT f w a) where showsPrec d (CofreeT w) = showParen (d > 10) $ showString "CofreeT " . showsPrec 11 w instance Read (w (CofreeF f a (CofreeT f w a))) => Read (CofreeT f w a) where readsPrec d = readParen (d > 10) $ \r -> [(CofreeT w, t) | ("CofreeT", s) <- lex r, (w, t) <- readsPrec 11 s] instance Eq (w (CofreeF f a (CofreeT f w a))) => Eq (CofreeT f w a) where CofreeT a == CofreeT b = a == b instance Ord (w (CofreeF f a (CofreeT f w a))) => Ord (CofreeT f w a) where compare (CofreeT a) (CofreeT b) = compare a b instance (Alternative f, Monad w) => Monad (CofreeT f w) where #if __GLASGOW_HASKELL__ < 710 return = CofreeT . return . (:< empty) {-# INLINE return #-} #endif CofreeT cx >>= f = CofreeT $ do a :< m <- cx b :< n <- runCofreeT $ f a return $ b :< (n <|> fmap (>>= f) m) instance (Alternative f, Applicative w) => Applicative (CofreeT f w) where pure = CofreeT . pure . (:< empty) {-# INLINE pure #-} wf <*> wa = CofreeT $ go <$> runCofreeT wf <*> runCofreeT wa where go (f :< t) a = case bimap f (fmap f) a of b :< n -> b :< (n <|> fmap (<*> wa) t) {-# INLINE (<*>) #-} instance Alternative f => MonadTrans (CofreeT f) where lift = CofreeT . liftM (:< empty) instance (Alternative f, MonadZip f, MonadZip m) => MonadZip (CofreeT f m) where mzip (CofreeT ma) (CofreeT mb) = CofreeT $ do (a :< fa, b :< fb) <- mzip ma mb return $ (a, b) :< (uncurry mzip <$> mzip fa fb) -- | Lift a natural transformation from @f@ to @g@ into a comonad homomorphism from @'CofreeT' f w@ to @'CofreeT' g w@ transCofreeT :: (Functor g, Comonad w) => (forall x. f x -> g x) -> CofreeT f w a -> CofreeT g w a transCofreeT t = CofreeT . liftW (fmap (transCofreeT t) . transCofreeF t) . runCofreeT -- | Unfold a @CofreeT@ comonad transformer from a coalgebra and an initial comonad. coiterT :: (Functor f, Comonad w) => (w a -> f (w a)) -> w a -> CofreeT f w a coiterT psi = CofreeT . extend (\w -> extract w :< fmap (coiterT psi) (psi w)) #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable2 (CofreeF f) where typeOf2 t = mkTyConApp cofreeFTyCon [typeOf1 (f t)] where f :: CofreeF f a b -> f a f = undefined instance (Typeable1 f, Typeable1 w) => Typeable1 (CofreeT f w) where typeOf1 t = mkTyConApp cofreeTTyCon [typeOf1 (f t), typeOf1 (w t)] where f :: CofreeT f w a -> f a f = undefined w :: CofreeT f w a -> w a w = undefined cofreeFTyCon, cofreeTTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 cofreeTTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeT" cofreeFTyCon = mkTyCon "Control.Comonad.Trans.Cofree.CofreeF" #else cofreeTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeT" cofreeFTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Cofree" "CofreeF" #endif {-# NOINLINE cofreeTTyCon #-} {-# NOINLINE cofreeFTyCon #-} #else #define Typeable1 Typeable #endif instance ( Typeable1 f, Typeable a, Typeable b , Data a, Data (f b), Data b ) => Data (CofreeF f a b) where gfoldl f z (a :< as) = z (:<) `f` a `f` as toConstr _ = cofreeFConstr gunfold k z c = case constrIndex c of 1 -> k (k (z (:<))) _ -> error "gunfold" dataTypeOf _ = cofreeFDataType dataCast1 f = gcast1 f instance ( Typeable1 f, Typeable1 w, Typeable a , Data (w (CofreeF f a (CofreeT f w a))) , Data a ) => Data (CofreeT f w a) where gfoldl f z (CofreeT w) = z CofreeT `f` w toConstr _ = cofreeTConstr gunfold k z c = case constrIndex c of 1 -> k (z CofreeT) _ -> error "gunfold" dataTypeOf _ = cofreeTDataType dataCast1 f = gcast1 f cofreeFConstr, cofreeTConstr :: Constr cofreeFConstr = mkConstr cofreeFDataType ":<" [] Infix cofreeTConstr = mkConstr cofreeTDataType "CofreeT" [] Prefix {-# NOINLINE cofreeFConstr #-} {-# NOINLINE cofreeTConstr #-} cofreeFDataType, cofreeTDataType :: DataType cofreeFDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeF" [cofreeFConstr] cofreeTDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeT" [cofreeTConstr] {-# NOINLINE cofreeFDataType #-} {-# NOINLINE cofreeTDataType #-} -- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a -- lowerF = fmap extract . unwrap free-4.12.4/src/Control/Comonad/Trans/Coiter.hs0000644000000000000000000001477512646574461017405 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- 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.Function (on) import Data.Functor.Identity import Data.Traversable import Prelude hiding (id,(.)) import Prelude.Extras -- | This is the coiterative comonad generated by a comonad newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) } #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where (==#) = on (==#) (fmap (fmap Lift1) . runCoiterT) instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT) instance (Functor w, Show1 w) => Show1 (CoiterT w) where showsPrec1 d (CoiterT as) = showParen (d > 10) $ showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as) instance (Functor w, Read1 w) => Read1 (CoiterT w) where readsPrec1 d = readParen (d > 10) $ \r -> [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s] -- | 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 Show (w (a, CoiterT w a)) => Show (CoiterT w a) where showsPrec d w = showParen (d > 10) $ showString "CoiterT " . showsPrec 11 w instance Read (w (a, CoiterT w a)) => Read (CoiterT w a) where readsPrec d = readParen (d > 10) $ \r -> [(CoiterT w, t) | ("CoiterT", s) <- lex r, (w, t) <- readsPrec 11 s] instance Eq (w (a, CoiterT w a)) => Eq (CoiterT w a) where CoiterT a == CoiterT b = a == b {-# INLINE (==) #-} instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where compare (CoiterT a) (CoiterT b) = compare a b {-# INLINE compare #-} -- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed. unfold :: Comonad w => (w a -> a) -> w a -> CoiterT w a unfold psi = CoiterT . extend (extract &&& unfold psi . extend psi) #if __GLASGOW_HASKELL__ < 707 instance Typeable1 w => Typeable1 (CoiterT w) where typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where w :: CoiterT w a -> w a w = undefined coiterTTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT" #else coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT" #endif {-# NOINLINE coiterTTyCon #-} #else #define Typeable1 Typeable #endif instance ( Typeable1 w, Typeable a , Data (w (a, CoiterT w a)) , Data a ) => Data (CoiterT w a) where gfoldl f z (CoiterT w) = z CoiterT `f` w toConstr _ = coiterTConstr gunfold k z c = case constrIndex c of 1 -> k (z CoiterT) _ -> error "gunfold" dataTypeOf _ = coiterTDataType dataCast1 f = gcast1 f coiterTConstr :: Constr coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix {-# NOINLINE coiterTConstr #-} coiterTDataType :: DataType coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr] {-# NOINLINE coiterTDataType #-} {- $example -} free-4.12.4/src/Control/Monad/0000755000000000000000000000000012646574461014175 5ustar0000000000000000free-4.12.4/src/Control/Monad/Free.hs0000644000000000000000000003326712646574461015425 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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.Foldable import Data.Profunctor import Data.Traversable import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Data import Prelude hiding (foldr) import Prelude.Extras -- | 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@. -- -- Being 'Free' being left adjoint to @U@ means that there is an isomorphism between -- -- @'Free' f -> m@ in the category of monads and @f -> U m@ in the category of functors. -- -- Morphisms in the category of monads are 'Monad' homomorphisms (natural transformations that respect 'return' and 'Control.Monad.join'). -- -- Morphisms in the category of functors are 'Functor' homomorphisms (natural transformations). -- -- Given this isomorphism, every monad homomorphism from @'Free' f@ to @m@ is equivalent to a natural transformation from @f@ to @m@ -- -- Showing that this isomorphism holds is left as an exercise. -- -- In practice, you can just view a @'Free' f a@ as many layers of @f@ wrapped around values of type @a@, where -- @('>>=')@ performs substitution and grafts new layers of @f@ in for each of the free variables. -- -- This can be very useful for modeling domain specific languages, trees, or other constructs. -- -- This instance of 'MonadFree' is fairly naive about the encoding. For more efficient free monad implementation see "Control.Monad.Free.Church", in particular note the 'Control.Monad.Free.Church.improve' combinator. -- You may also want to take a look at the @kan-extensions@ package (). -- -- A number of common monads arise as free monads, -- -- * Given @data Empty a@, @'Free' Empty@ is isomorphic to the 'Data.Functor.Identity' monad. -- -- * @'Free' 'Maybe'@ can be used to model a partiality monad where each layer represents running the computation for a while longer. data Free f a = Pure a | Free (f (Free f a)) #if __GLASGOW_HASKELL__ >= 707 deriving (Typeable) #endif instance (Functor f, Eq1 f) => Eq1 (Free f) where Pure a ==# Pure b = a == b Free fa ==# Free fb = fmap Lift1 fa ==# fmap Lift1 fb _ ==# _ = False instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where Pure a == Pure b = a == b Free fa == Free fb = fa == fb _ == _ = False instance (Functor f, Ord1 f) => Ord1 (Free f) where Pure a `compare1` Pure b = a `compare` b Pure _ `compare1` Free _ = LT Free _ `compare1` Pure _ = GT Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where Pure a `compare` Pure b = a `compare` b Pure _ `compare` Free _ = LT Free _ `compare` Pure _ = GT Free fa `compare` Free fb = fa `compare` fb instance (Functor f, Show1 f) => Show1 (Free f) where showsPrec1 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a showsPrec1 d (Free m) = showParen (d > 10) $ showString "Free " . showsPrec1 11 (fmap Lift1 m) instance (Show (f (Free f a)), Show a) => Show (Free f a) where showsPrec d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a showsPrec d (Free m) = showParen (d > 10) $ showString "Free " . showsPrec 11 m instance (Functor f, Read1 f) => Read1 (Free f) where readsPrec1 d r = readParen (d > 10) (\r' -> [ (Pure m, t) | ("Pure", s) <- lex r' , (m, t) <- readsPrec 11 s]) r ++ readParen (d > 10) (\r' -> [ (Free (fmap lower1 m), t) | ("Free", s) <- lex r' , (m, t) <- readsPrec1 11 s]) r instance (Read (f (Free f a)), Read a) => Read (Free f a) where readsPrec d r = readParen (d > 10) (\r' -> [ (Pure m, t) | ("Pure", s) <- lex r' , (m, t) <- readsPrec 11 s]) r ++ readParen (d > 10) (\r' -> [ (Free m, t) | ("Free", s) <- lex r' , (m, t) <- readsPrec 11 s]) r instance Functor f => Functor (Free f) where fmap f = go where go (Pure a) = Pure (f a) go (Free fa) = Free (go <$> fa) {-# INLINE fmap #-} instance Functor f => Apply (Free f) where Pure a <.> Pure b = Pure (a b) Pure a <.> Free fb = Free $ fmap a <$> fb Free fa <.> b = Free $ (<.> b) <$> fa instance Functor f => Applicative (Free f) where pure = Pure {-# INLINE pure #-} Pure a <*> Pure b = Pure $ a b Pure a <*> Free mb = Free $ fmap a <$> mb Free ma <*> b = Free $ (<*> b) <$> ma instance Functor f => Bind (Free f) where Pure a >>- f = f a Free m >>- f = Free ((>>- f) <$> m) instance Functor f => Monad (Free f) where return = pure {-# INLINE return #-} Pure a >>= f = f a Free m >>= f = Free ((>>= f) <$> m) instance Functor f => MonadFix (Free f) where mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free" -- | This violates the Alternative laws, handle with care. instance Alternative v => Alternative (Free v) where empty = Free empty {-# INLINE empty #-} a <|> b = Free (pure a <|> pure b) {-# INLINE (<|>) #-} -- | This violates the MonadPlus laws, handle with care. instance (Functor v, MonadPlus v) => MonadPlus (Free v) where mzero = Free mzero {-# INLINE mzero #-} a `mplus` b = Free (return a `mplus` return b) {-# INLINE mplus #-} -- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\". instance MonadTrans Free where lift = Free . liftM Pure {-# INLINE lift #-} instance Foldable f => Foldable (Free f) where foldMap f = go where go (Pure a) = f a go (Free fa) = foldMap go fa {-# INLINE foldMap #-} foldr f = go where go r free = case free of Pure a -> f a r Free fa -> foldr (flip go) r fa {-# INLINE foldr #-} #if MIN_VERSION_base(4,6,0) foldl' f = go where go r free = case free of Pure a -> f r a Free fa -> foldl' go r fa {-# INLINE foldl' #-} #endif instance Foldable1 f => Foldable1 (Free f) where foldMap1 f = go where go (Pure a) = f a go (Free fa) = foldMap1 go fa {-# INLINE foldMap1 #-} instance Traversable f => Traversable (Free f) where traverse f = go where go (Pure a) = Pure <$> f a go (Free fa) = Free <$> traverse go fa {-# INLINE traverse #-} instance Traversable1 f => Traversable1 (Free f) where traverse1 f = go where go (Pure a) = Pure <$> f a go (Free fa) = Free <$> traverse1 go fa {-# INLINE traverse1 #-} instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where tell = lift . tell {-# INLINE tell #-} listen = lift . listen . retract {-# INLINE listen #-} pass = lift . pass . retract {-# INLINE pass #-} instance (Functor m, MonadReader e m) => MonadReader e (Free m) where ask = lift ask {-# INLINE ask #-} local f = lift . local f . retract {-# INLINE local #-} instance (Functor m, MonadState s m) => MonadState s (Free m) where get = lift get {-# INLINE get #-} put s = lift (put s) {-# INLINE put #-} instance (Functor m, MonadError e m) => MonadError e (Free m) where throwError = lift . throwError {-# INLINE throwError #-} catchError as f = lift (catchError (retract as) (retract . f)) {-# INLINE catchError #-} instance (Functor m, MonadCont m) => MonadCont (Free m) where callCC f = lift (callCC (retract . f . liftM lift)) {-# INLINE callCC #-} instance Functor f => MonadFree f (Free f) where wrap = Free {-# INLINE wrap #-} -- | -- 'retract' is the left inverse of 'lift' and 'liftF' -- -- @ -- 'retract' . 'lift' = 'id' -- 'retract' . 'liftF' = 'id' -- @ retract :: Monad f => Free f a -> f a retract (Pure a) = return a retract (Free as) = as >>= retract -- | Tear down a 'Free' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> Free f a -> a iter _ (Pure a) = a iter phi (Free m) = phi (iter phi <$> m) -- | Like 'iter' for applicative values. iterA :: (Applicative p, Functor f) => (f (p a) -> p a) -> Free f a -> p a iterA _ (Pure x) = pure x iterA phi (Free f) = phi (iterA phi <$> f) -- | Like 'iter' for monadic values. iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a iterM _ (Pure x) = return x iterM phi (Free f) = phi (iterM phi <$> f) -- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'FreeT' f@ to @'FreeT' g@. hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b hoistFree _ (Pure a) = Pure a hoistFree f (Free as) = Free (hoistFree f <$> f as) -- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism. foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a foldFree _ (Pure a) = return a foldFree f (Free as) = f as >>= foldFree f -- | Convert a 'Free' monad from "Control.Monad.Free" to a 'FreeT.FreeT' monad -- from "Control.Monad.Trans.Free". toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a toFreeT (Pure a) = FreeT.FreeT (return (FreeT.Pure a)) toFreeT (Free f) = FreeT.FreeT (return (FreeT.Free (fmap toFreeT f))) -- | Cuts off a tree of computations at a given depth. -- If the depth is 0 or less, no computation nor -- monadic effects will take place. -- -- Some examples (n ≥ 0): -- -- prop> cutoff 0 _ == return Nothing -- prop> cutoff (n+1) . return == return . Just -- prop> cutoff (n+1) . lift == lift . liftM Just -- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) -- -- Calling 'retract . cutoff n' is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a) cutoff n _ | n <= 0 = return Nothing cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f cutoff _ m = Just <$> m -- | Unfold a free monad from a seed. unfold :: Functor f => (b -> Either a (f b)) -> b -> Free f a unfold f = f >>> either Pure (Free . fmap (unfold f)) -- | Unfold a free monad from a seed, monadically. unfoldM :: (Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a) unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f)) -- | This is @Prism' (Free f a) a@ in disguise -- -- >>> preview _Pure (Pure 3) -- Just 3 -- -- >>> review _Pure 3 :: Free Maybe Int -- Pure 3 _Pure :: forall f m a p. (Choice p, Applicative m) => p a (m a) -> p (Free f a) (m (Free f a)) _Pure = dimap impure (either pure (fmap Pure)) . right' where impure (Pure x) = Right x impure x = Left x {-# INLINE impure #-} {-# INLINE _Pure #-} -- | This is @Prism' (Free f a) (f (Free f a))@ in disguise -- -- >>> preview _Free (review _Free (Just (Pure 3))) -- Just (Just (Pure 3)) -- -- >>> review _Free (Just (Pure 3)) -- Free (Just (Pure 3)) _Free :: forall f m a p. (Choice p, Applicative m) => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a)) _Free = dimap unfree (either pure (fmap Free)) . right' where unfree (Free x) = Right x unfree x = Left x {-# INLINE unfree #-} {-# INLINE _Free #-} #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Free f) where typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where f :: Free f a -> f a f = undefined freeTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 freeTyCon = mkTyCon "Control.Monad.Free.Free" #else freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free" #endif {-# NOINLINE freeTyCon #-} instance ( Typeable1 f, Typeable a , Data a, Data (f (Free f a)) ) => Data (Free f a) where gfoldl f z (Pure a) = z Pure `f` a gfoldl f z (Free as) = z Free `f` as toConstr Pure{} = pureConstr toConstr Free{} = freeConstr gunfold k z c = case constrIndex c of 1 -> k (z Pure) 2 -> k (z Free) _ -> error "gunfold" dataTypeOf _ = freeDataType dataCast1 f = gcast1 f pureConstr, freeConstr :: Constr pureConstr = mkConstr freeDataType "Pure" [] Prefix freeConstr = mkConstr freeDataType "Free" [] Prefix {-# NOINLINE pureConstr #-} {-# NOINLINE freeConstr #-} freeDataType :: DataType freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr] {-# NOINLINE freeDataType #-} #endif free-4.12.4/src/Control/Monad/Free/0000755000000000000000000000000012646574461015056 5ustar0000000000000000free-4.12.4/src/Control/Monad/Free/Church.hs0000644000000000000000000001634212646574461016634 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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 qualified Control.Monad.Free as Free 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.Functor.Bind 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 foldr f r xs = runF xs f (foldr (.) id) r {-# INLINE foldr #-} #if MIN_VERSION_base(4,6,0) foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z {-# INLINE foldl' #-} #endif -- | 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. cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a) cutoff n = toF . Free.cutoff n . fromF free-4.12.4/src/Control/Monad/Free/Class.hs0000644000000000000000000001321012646574461016454 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeFamilies #-} #endif {-# OPTIONS_GHC -fno-warn-deprecations #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #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.List import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative import Data.Monoid #endif -- | -- Monads provide substitution ('fmap') and renormalization ('Control.Monad.join'): -- -- @m '>>=' f = 'Control.Monad.join' ('fmap' f m)@ -- -- A free 'Monad' is one that does no work during the normalization step beyond simply grafting the two monadic values together. -- -- @[]@ is not a free 'Monad' (in this sense) because @'Control.Monad.join' [[a]]@ smashes the lists flat. -- -- On the other hand, consider: -- -- @ -- data Tree a = Bin (Tree a) (Tree a) | Tip a -- @ -- -- @ -- instance 'Monad' Tree where -- 'return' = Tip -- Tip a '>>=' f = f a -- Bin l r '>>=' f = Bin (l '>>=' f) (r '>>=' f) -- @ -- -- This 'Monad' is the free 'Monad' of Pair: -- -- @ -- data Pair a = Pair a a -- @ -- -- And we could make an instance of 'MonadFree' for it directly: -- -- @ -- instance 'MonadFree' Pair Tree where -- 'wrap' (Pair l r) = Bin l r -- @ -- -- Or we could choose to program with @'Control.Monad.Free.Free' Pair@ instead of 'Tree' -- and thereby avoid having to define our own 'Monad' instance. -- -- Moreover, "Control.Monad.Free.Church" provides a 'MonadFree' -- instance that can improve the /asymptotic/ complexity of code that -- constructs free monads by effectively reassociating the use of -- ('>>='). You may also want to take a look at the @kan-extensions@ -- package (). -- -- See 'Control.Monad.Free.Free' for a more formal definition of the free 'Monad' -- for a 'Functor'. class Monad m => MonadFree f m | m -> f where -- | Add a layer. -- -- @ -- wrap (fmap f x) ≡ wrap (fmap return x) >>= f -- @ wrap :: f (m a) -> m a #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a wrap = join . lift . wrap . fmap return #endif instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm instance (Functor f, MonadFree f m) => MonadFree f (Lazy.StateT s m) where wrap fm = Lazy.StateT $ \s -> wrap $ flip Lazy.runStateT s <$> fm instance (Functor f, MonadFree f m) => MonadFree f (Strict.StateT s m) where wrap fm = Strict.StateT $ \s -> wrap $ flip Strict.runStateT s <$> fm instance (Functor f, MonadFree f m) => MonadFree f (ContT r m) where wrap t = ContT $ \h -> wrap (fmap (\p -> runContT p h) t) instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.WriterT w m) where wrap = Lazy.WriterT . wrap . fmap Lazy.runWriterT instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.WriterT w m) where wrap = Strict.WriterT . wrap . fmap Strict.runWriterT instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.RWST r w s m) where wrap fm = Strict.RWST $ \r s -> wrap $ fmap (\m -> Strict.runRWST m r s) fm instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.RWST r w s m) where wrap fm = Lazy.RWST $ \r s -> wrap $ fmap (\m -> Lazy.runRWST m r s) fm instance (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where wrap = MaybeT . wrap . fmap runMaybeT instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where wrap = IdentityT . wrap . fmap runIdentityT instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where wrap = ListT . wrap . fmap runListT 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 (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 -- | 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-4.12.4/src/Control/Monad/Free/TH.hs0000644000000000000000000003324312646574461015732 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #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 Language.Haskell.TH #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif data Arg = Captured Type Exp | Param Type deriving (Show) params :: [Arg] -> [Type] params [] = [] params (Param t : xs) = t : params xs params (_ : xs) = params xs captured :: [Arg] -> [(Type, Exp)] captured [] = [] captured (Captured t e : xs) = (t, e) : captured xs captured (_ : xs) = captured xs zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp] zipExprs (p:ps) cs (Param _ : as) = p : zipExprs ps cs as zipExprs ps (c:cs) (Captured _ _ : as) = c : zipExprs ps cs as zipExprs _ _ _ = [] tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV name) = name tyVarBndrName (KindedTV name _) = name 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 "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 tyVarBndrName bs usesTV _ _ = False -- | Analyze constructor argument. mkArg :: Name -> Type -> Q Arg mkArg 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 (name /= n) $ fail "return type is not the parameter" let tup = foldl AppT (TupleT $ length ts) ts xs <- mapM (const $ newName "x") ts return $ Captured tup (LamE (map VarP xs) (TupE (map VarE xs))) _ -> fail "don't know how to make Arg" | otherwise = return $ Param t where arrowsToTuple (AppT (AppT ArrowT t1) (VarT name)) = return ([t1], name) arrowsToTuple (AppT (AppT ArrowT t1) t2) = do (ts, name) <- arrowsToTuple t2 return (t1:ts, name) arrowsToTuple _ = fail "return type is not a variable" -- | 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 _ _ = fail "can't unify more than 2 arguments that use type parameter" liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> 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 q = tvbs ++ map PlainTV (qa ++ m : ns) qa = case retType of VarT b | a == b -> [a]; _ -> [] f' = foldl AppT f (map VarT ns) return $ concat [ if typeSig #if MIN_VERSION_template_haskell(2,10,0) then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ] #else then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ] #endif else [] , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ] -- | Provide free monadic actions for a single value constructor. liftCon :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec] liftCon typeSig ts cx f n ns con = 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 con' _ -> fail "Unsupported constructor type" -- | Provide free monadic actions for a type declaration. liftDec :: Bool -- ^ Include type signature? -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. -> Dec -- ^ Data type declaration. -> Q [Dec] #if MIN_VERSION_template_haskell(2,11,0) liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs _ cons _) #else liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _) #endif | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable" | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTyName (init tyNames)) cons' where cons' = case onlyCons of Nothing -> cons Just ns -> filter (\c -> constructorName c `elem` ns) cons tyNames = map tyVarBndrName tyVarBndrs nextTyName = last tyNames con = ConT tyName liftDec _ _ dec = fail $ "liftDec: Don't know how to lift " ++ show dec -- | Get construstor name. constructorName :: Con -> Name constructorName (NormalC name _) = name constructorName (RecC name _) = name constructorName (InfixC _ name _) = name constructorName (ForallC _ _ c) = constructorName c constructorName _ = error "Unsupported constructor type" -- | Generate monadic actions for a data type. genFree :: Bool -- ^ Include type signature? -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@. -> Name -- ^ Type name. -> Q [Dec] -- ^ Generated declarations. genFree typeSig cnames tyCon = do info <- reify tyCon case info of TyConI dec -> liftDec typeSig cnames dec _ -> fail "makeFree expects a type constructor" -- | Generate monadic action for a single constructor of a data type. genFreeCon :: Bool -- ^ Include type signature? -> Name -- ^ Constructor name. -> Q [Dec] -- ^ Generated declarations. genFreeCon typeSig cname = do info <- reify cname case info of DataConI _ _ tname #if !(MIN_VERSION_template_haskell(2,11,0)) _ #endif -> genFree typeSig (Just [cname]) tname _ -> fail "makeFreeCon expects a data constructor" -- | @$('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-4.12.4/src/Control/Monad/Trans/0000755000000000000000000000000012646574461015264 5ustar0000000000000000free-4.12.4/src/Control/Monad/Trans/Free.hs0000644000000000000000000004026612646574461016511 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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 , 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.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class 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.Monoid import Data.Function (on) import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Data import Prelude.Extras #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable #endif -- | The base functor for a free monad. data FreeF f a b = Pure a | Free (f b) deriving (Eq,Ord,Show,Read #if __GLASGOW_HASKELL__ >= 707 ,Typeable #endif ) instance Show1 f => Show2 (FreeF f) where showsPrec2 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a showsPrec2 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as instance (Show1 f, Show a) => Show1 (FreeF f a) where showsPrec1 = showsPrec2 instance Read1 f => Read2 (FreeF f) where readsPrec2 d r = readParen (d > 10) (\r' -> [ (Pure m, t) | ("Pure", s) <- lex r' , (m, t) <- readsPrec 11 s]) r ++ readParen (d > 10) (\r' -> [ (Free m, t) | ("Free", s) <- lex r' , (m, t) <- readsPrec1 11 s]) r instance (Read1 f, Read a) => Read1 (FreeF f a) where readsPrec1 = readsPrec2 instance Eq1 f => Eq2 (FreeF f) where Pure a ==## Pure b = a == b Free as ==## Free bs = as ==# bs _ ==## _ = False instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where (==#) = (==##) instance Ord1 f => Ord2 (FreeF f) where Pure a `compare2` Pure b = a `compare` b Pure _ `compare2` Free _ = LT Free _ `compare2` Pure _ = GT Free fa `compare2` Free fb = fa `compare1` fb instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where compare1 = compare2 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 #-} deriving instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a) instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where (==#) = on (==#) (fmap (Lift1 . fmap Lift1) . runFreeT) deriving instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a) instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT) instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where showsPrec1 d (FreeT m) = showParen (d > 10) $ showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m) instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where showsPrec d (FreeT m) = showParen (d > 10) $ showString "FreeT " . showsPrec 11 m instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where readsPrec1 d = readParen (d > 10) $ \r -> [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s] instance Read (m (FreeF f a (FreeT f m a))) => Read (FreeT f m a) where readsPrec d = readParen (d > 10) $ \r -> [ (FreeT m,t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec 11 s] instance (Functor f, Monad m) => Functor (FreeT f m) where fmap f (FreeT m) = FreeT (liftM f' m) where f' (Pure a) = Pure (f a) f' (Free as) = Free (fmap (fmap f) as) instance (Functor f, Monad m) => Applicative (FreeT f m) where pure a = FreeT (return (Pure a)) {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} instance (Functor f, Monad m) => Apply (FreeT f m) where (<.>) = (<*>) instance (Functor f, Monad m) => Bind (FreeT f m) where (>>-) = (>>=) instance (Functor f, Monad m) => Monad (FreeT f m) where fail e = FreeT (fail e) return = pure {-# INLINE return #-} FreeT m >>= f = FreeT $ m >>= \v -> case v of Pure a -> runFreeT (f a) Free w -> return (Free (fmap (>>= f) w)) instance MonadTrans (FreeT f) where lift = FreeT . liftM Pure {-# INLINE lift #-} instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where liftIO = lift . liftIO {-# INLINE liftIO #-} 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 <>)) <$> y pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m where clean = pass . liftM (\x -> (x, const mempty)) pass' = join . liftM g g (Pure ((x, f), w)) = tell (f w) >> return (Pure x) g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f #if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-} #endif instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-} #if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-} #endif instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where throwError = lift . throwError {-# INLINE throwError #-} FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f) instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure)) instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where empty = FreeT mzero FreeT ma <|> FreeT mb = FreeT (mplus ma mb) {-# INLINE (<|>) #-} instance (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where mzero = FreeT mzero {-# INLINE mzero #-} mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb) {-# INLINE mplus #-} instance (Functor f, Monad m) => MonadFree f (FreeT f m) where wrap = FreeT . return . Free {-# INLINE wrap #-} instance (Functor f, MonadThrow m) => MonadThrow (FreeT f m) where throwM = lift . throwM {-# INLINE throwM #-} instance (Functor f, MonadCatch m) => MonadCatch (FreeT f m) where FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m `Control.Monad.Catch.catch` (runFreeT . f) {-# INLINE catch #-} -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a iterT f (FreeT m) = do val <- m case fmap (iterT f) val of Pure x -> return x Free y -> f y -- | Tear down a free monad transformer using iteration over a transformer. iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a iterTM f (FreeT m) = do val <- lift m case fmap (iterTM f) val of Pure x -> return x Free y -> f y instance (Foldable m, Foldable f) => Foldable (FreeT f m) where foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ -- -- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@ hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT -- | Pull out and join @m@ layers of @'FreeT' f m a@. joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a) joinFreeT (FreeT m) = m >>= joinFreeF where joinFreeF (Pure x) = return (return x) joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f -- | -- 'retract' is the left inverse of 'liftF' -- -- @ -- 'retract' . 'liftF' = 'id' -- @ retract :: Monad f => Free f a -> f a retract m = case runIdentity (runFreeT m) of Pure a -> return a Free as -> as >>= retract -- | Tear down a 'Free' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> Free f a -> a iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) -- | Like 'iter' for monadic values. iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a iterM phi = iterT phi . hoistFreeT (return . runIdentity) -- | Cuts off a tree of computations at a given depth. -- If the depth is @0@ or less, no computation nor -- monadic effects will take place. -- -- Some examples (@n ≥ 0@): -- -- @ -- 'cutoff' 0 _ ≡ 'return' 'Nothing' -- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' -- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' -- 'cutoff' (n+1) '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('cutoff' n) -- @ -- -- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a) cutoff n _ | n <= 0 = return Nothing cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m -- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@. -- This is sort of the opposite for @'cutoff'@. -- -- Some examples (@n ≥ 0@): -- -- @ -- 'partialIterT' 0 _ m ≡ m -- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return' -- 'partialIterT' (n+1) phi '.' 'lift' ≡ 'lift' -- 'partialIterT' (n+1) phi '.' 'wrap' ≡ 'join' . 'lift' . phi -- @ partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b partialIterT n phi m | n <= 0 = m | otherwise = FreeT $ do val <- runFreeT m case val of Pure a -> return (Pure a) Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi -- | @intersperseT f m@ inserts a layer @f@ between every two layers in -- @m@. -- -- @ -- 'intersperseT' f '.' 'return' ≡ 'return' -- 'intersperseT' f '.' 'lift' ≡ 'lift' -- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap')) -- @ intersperseT :: (Monad m, Functor f) => f a -> FreeT f m b -> FreeT f m b intersperseT f (FreeT m) = FreeT $ do val <- m case val of Pure x -> return $ Pure x Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y -- | Tear down a free monad transformer using Monad instance for @t m@. retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a retractT (FreeT m) = do val <- lift m case val of Pure x -> return x Free y -> y >>= retractT -- | @intercalateT f m@ inserts a layer @f@ between every two layers in -- @m@ and then retracts the result. -- -- @ -- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f -- @ #if __GLASGOW_HASKELL__ < 710 intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b #else intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b #endif intercalateT f (FreeT m) = do val <- lift m case val of Pure x -> return x Free y -> y >>= iterTM (\x -> f >> join x) #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable2 (FreeF f) where typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where f :: FreeF f a b -> f a f = undefined instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where f :: FreeT f w a -> f a f = undefined w :: FreeT f w a -> w a w = undefined freeFTyCon, freeTTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT" freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF" #else freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT" freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF" #endif {-# NOINLINE freeTTyCon #-} {-# NOINLINE freeFTyCon #-} instance ( Typeable1 f, Typeable a, Typeable b , Data a, Data (f b), Data b ) => Data (FreeF f a b) where gfoldl f z (Pure a) = z Pure `f` a gfoldl f z (Free as) = z Free `f` as toConstr Pure{} = pureConstr toConstr Free{} = freeConstr gunfold k z c = case constrIndex c of 1 -> k (z Pure) 2 -> k (z Free) _ -> error "gunfold" dataTypeOf _ = freeFDataType dataCast1 f = gcast1 f instance ( Typeable1 f, Typeable1 w, Typeable a , Data (w (FreeF f a (FreeT f w a))) , Data a ) => Data (FreeT f w a) where gfoldl f z (FreeT w) = z FreeT `f` w toConstr _ = freeTConstr gunfold k z c = case constrIndex c of 1 -> k (z FreeT) _ -> error "gunfold" dataTypeOf _ = freeTDataType dataCast1 f = gcast1 f pureConstr, freeConstr, freeTConstr :: Constr pureConstr = mkConstr freeFDataType "Pure" [] Prefix freeConstr = mkConstr freeFDataType "Free" [] Prefix freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix {-# NOINLINE pureConstr #-} {-# NOINLINE freeConstr #-} {-# NOINLINE freeTConstr #-} freeFDataType, freeTDataType :: DataType freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr] freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr] {-# NOINLINE freeFDataType #-} {-# NOINLINE freeTDataType #-} #endif free-4.12.4/src/Control/Monad/Trans/Iter.hs0000644000000000000000000003515212646574461016531 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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 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.Identity import Data.Function (on) import Data.Monoid import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Typeable import Data.Data import Prelude.Extras #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable hiding (fold) import Data.Traversable hiding (mapM) #endif -- | The monad supporting iteration based over a base monad @m@. -- -- @ -- 'IterT' ~ 'FreeT' 'Identity' -- @ newtype IterT m a = IterT { runIterT :: m (Either a (IterT m a)) } #if __GLASGOW_HASKELL__ >= 707 deriving (Typeable) #endif -- | Plain iterative computations. type Iter = IterT Identity -- | Builds an iterative computation from one first step. -- -- prop> runIter . iter == id iter :: Either a (Iter a) -> Iter a iter = IterT . Identity {-# INLINE iter #-} -- | Executes the first step of an iterative computation -- -- prop> iter . runIter == id runIter :: Iter a -> Either a (Iter a) runIter = runIdentity . runIterT {-# INLINE runIter #-} instance (Functor m, Eq1 m) => Eq1 (IterT m) where (==#) = on (==#) (fmap (fmap Lift1) . runIterT) instance Eq (m (Either a (IterT m a))) => Eq (IterT m a) where IterT m == IterT n = m == n instance (Functor m, Ord1 m) => Ord1 (IterT m) where compare1 = on compare1 (fmap (fmap Lift1) . runIterT) instance Ord (m (Either a (IterT m a))) => Ord (IterT m a) where compare (IterT m) (IterT n) = compare m n instance (Functor m, Show1 m) => Show1 (IterT m) where showsPrec1 d (IterT m) = showParen (d > 10) $ showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m) instance Show (m (Either a (IterT m a))) => Show (IterT m a) where showsPrec d (IterT m) = showParen (d > 10) $ showString "IterT " . showsPrec 11 m instance (Functor m, Read1 m) => Read1 (IterT m) where readsPrec1 d = readParen (d > 10) $ \r -> [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s] instance Read (m (Either a (IterT m a))) => Read (IterT m a) where readsPrec d = readParen (d > 10) $ \r -> [ (IterT m,t) | ("IterT",s) <- lex r, (m,t) <- readsPrec 11 s] 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 (>>=) #-} 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 <>) <$> y pass m = IterT . pass' . runIterT . hoistIterT clean $ listen m where clean = pass . liftM (\x -> (x, const mempty)) pass' = join . liftM g g (Left ((x, f), w)) = tell (f w) >> return (Left x) g (Right f) = return . Right . IterT . pass' . runIterT $ f #if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-} #endif instance MonadState s m => MonadState s (IterT m) where get = lift get {-# INLINE get #-} put s = lift (put s) {-# INLINE put #-} #if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-} #endif instance MonadError e m => MonadError e (IterT m) where throwError = lift . throwError {-# INLINE throwError #-} IterT m `catchError` f = IterT $ liftM (fmap (`catchError` f)) m `catchError` (runIterT . f) instance MonadIO m => MonadIO (IterT m) where liftIO = lift . liftIO instance MonadCont m => MonadCont (IterT m) where callCC f = IterT $ callCC (\k -> runIterT $ f (lift . k . Left)) instance Monad m => MonadFree Identity (IterT m) where wrap = IterT . return . Right . runIdentity {-# INLINE wrap #-} instance MonadThrow m => MonadThrow (IterT m) where throwM = lift . throwM {-# INLINE throwM #-} instance MonadCatch m => MonadCatch (IterT m) where catch (IterT m) f = IterT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m `Control.Monad.Catch.catch` (runIterT . f) {-# INLINE catch #-} -- | Adds an extra layer to a free monad value. -- -- In particular, for the iterative monad 'Iter', this makes the -- computation require one more step, without changing its final -- result. -- -- prop> runIter (delay ma) == Right ma delay :: (Monad f, MonadFree f m) => m a -> m a delay = wrap . return {-# INLINE delay #-} -- | -- 'retract' is the left inverse of 'lift' -- -- @ -- 'retract' . 'lift' = 'id' -- @ retract :: Monad m => IterT m a -> m a retract m = runIterT m >>= either return retract -- | Tear down a 'Free' 'Monad' using iteration. fold :: Monad m => (m a -> a) -> IterT m a -> a fold phi (IterT m) = phi (either id (fold phi) `liftM` m) -- | Like 'fold' with monadic result. foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a foldM phi (IterT m) = phi (either return (foldM phi) `liftM` m) -- | Lift a monad homomorphism from @m@ to @n@ into a Monad homomorphism from @'IterT' m@ to @'IterT' n@. hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b hoistIterT f (IterT as) = IterT (fmap (hoistIterT f) `liftM` f as) -- | Lifts a plain, non-terminating computation into a richer environment. -- 'liftIter' is a 'Monad' homomorphism. liftIter :: (Monad m) => Iter a -> IterT m a liftIter = hoistIterT (return . runIdentity) -- | A computation that never terminates never :: (Monad f, MonadFree f m) => m a never = delay never -- | Repeatedly run a computation until it produces a 'Just' value. -- This can be useful when paired with a monad that has side effects. -- -- For example, we may have @genId :: IO (Maybe Id)@ that uses a random -- number generator to allocate ids, but fails if it finds a collision. -- We can repeatedly run this with -- -- @ -- 'retract' ('untilJust' genId) :: IO Id -- @ untilJust :: (Monad m) => m (Maybe a) -> IterT m a untilJust f = maybe (delay (untilJust f)) return =<< lift f {-# INLINE untilJust #-} -- | Cuts off an iterative computation after a given number of -- steps. If the number of steps is 0 or less, no computation nor -- monadic effects will take place. -- -- The step where the final value is produced also counts towards the limit. -- -- Some examples (@n ≥ 0@): -- -- @ -- 'cutoff' 0 _ ≡ 'return' 'Nothing' -- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just' -- 'cutoff' (n+1) '.' 'lift' ≡ 'lift' '.' 'liftM' 'Just' -- 'cutoff' (n+1) '.' 'delay' ≡ 'delay' . 'cutoff' n -- 'cutoff' n 'never' ≡ 'iterate' 'delay' ('return' 'Nothing') '!!' n -- @ -- -- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Monad m) => Integer -> IterT m a -> IterT m (Maybe a) cutoff n | n <= 0 = const $ return Nothing cutoff n = IterT . liftM (either (Left . Just) (Right . cutoff (n - 1))) . runIterT -- | Interleaves the steps of a finite list of iterative computations, and -- collects their results. -- -- The resulting computation has as many steps as the longest computation -- in the list. interleave :: Monad m => [IterT m a] -> IterT m [a] interleave ms = IterT $ do xs <- mapM runIterT ms if null (rights xs) then return . Left $ lefts xs else return . Right . interleave $ map (either return id) xs {-# INLINE interleave #-} -- | Interleaves the steps of a finite list of computations, and discards their -- results. -- -- The resulting computation has as many steps as the longest computation -- in the list. -- -- Equivalent to @'void' '.' 'interleave'@. interleave_ :: (Monad m) => [IterT m a] -> IterT m () interleave_ [] = return () interleave_ xs = IterT $ liftM (Right . interleave_ . rights) $ mapM runIterT xs {-# INLINE interleave_ #-} instance (Monad m, Monoid a) => Monoid (IterT m a) where mempty = return mempty x `mappend` y = IterT $ do x' <- runIterT x y' <- runIterT y case (x', y') of ( Left a, Left b) -> return . Left $ a `mappend` b ( Left a, Right b) -> return . Right $ liftM (a `mappend`) b (Right a, Left b) -> return . Right $ liftM (`mappend` b) a (Right a, Right b) -> return . Right $ a `mappend` b 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 <> a') xs #if __GLASGOW_HASKELL__ < 707 instance Typeable1 m => Typeable1 (IterT m) where typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where f :: IterT m a -> m a f = undefined freeTyCon :: TyCon #if __GLASGOW_HASKELL__ < 704 freeTyCon = mkTyCon "Control.Monad.Iter.IterT" #else freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT" #endif {-# NOINLINE freeTyCon #-} #else #define Typeable1 Typeable #endif instance ( Typeable1 m, Typeable a , Data (m (Either a (IterT m a))) , Data a ) => Data (IterT m a) where gfoldl f z (IterT as) = z IterT `f` as toConstr IterT{} = iterConstr gunfold k z c = case constrIndex c of 1 -> k (z IterT) _ -> error "gunfold" dataTypeOf _ = iterDataType dataCast1 f = gcast1 f iterConstr :: Constr iterConstr = mkConstr iterDataType "IterT" [] Prefix {-# NOINLINE iterConstr #-} iterDataType :: DataType iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr] {-# NOINLINE iterDataType #-} {- $examples * * -} free-4.12.4/src/Control/Monad/Trans/Free/0000755000000000000000000000000012646574461016145 5ustar0000000000000000free-4.12.4/src/Control/Monad/Trans/Free/Church.hs0000644000000000000000000002402712646574461017722 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- 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 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.Function #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable (Foldable) import Data.Traversable (Traversable) #endif -- | The \"free monad transformer\" for a functor @f@ newtype FT f m a = FT { runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r } instance (Functor f, Monad m, Eq (FreeT f m a)) => Eq (FT f m a) where (==) = (==) `on` fromFT instance (Functor f, Monad m, Ord (FreeT f m a)) => Ord (FT f m a) where compare = compare `on` fromFT instance Functor (FT f m) where fmap f (FT k) = FT $ \a fr -> k (a . f) fr instance Apply (FT f m) where (<.>) = (<*>) instance Applicative (FT f m) where pure a = FT $ \k _ -> k a FT fk <*> FT ak = FT $ \b fr -> fk (\e -> ak (\d -> b (e d)) fr) fr instance Bind (FT f m) where (>>-) = (>>=) instance Monad (FT f m) where return = pure FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr instance MonadFree f (FT f m) where wrap f = FT (\kp kf -> kf (\ft -> runFT ft kp kf) f) instance MonadTrans (FT f) where lift m = FT (\a _ -> m >>= a) instance Alternative m => Alternative (FT f m) where empty = FT (\_ _ -> empty) FT k1 <|> FT k2 = FT $ \a fr -> k1 a fr <|> k2 a fr instance MonadPlus m => MonadPlus (FT f m) where mzero = FT (\_ _ -> mzero) mplus (FT k1) (FT k2) = FT $ \a fr -> k1 a fr `mplus` k2 a fr instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where foldr f r xs = F.foldr (<<<) id inner r where inner = runFT xs (return . f) (\xg xf -> F.foldr (liftM2 (<<<) . xg) (return id) xf) {-# INLINE foldr #-} #if MIN_VERSION_base(4,6,0) foldl' f z xs = F.foldl' (!>>>) id inner z where (!>>>) h g = \r -> g $! h r inner = runFT xs (return . flip f) (\xg xf -> F.foldr (liftM2 (>>>) . xg) (return id) xf) {-# INLINE foldl' #-} #endif instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree where traversePure = return . fmap return . f traverseFree xg = return . fmap (wrap . fmap (join . lift)) . T.traverse (T.sequenceA . xg) instance (MonadIO m) => MonadIO (FT f m) where liftIO = lift . liftIO {-# INLINE liftIO #-} instance (Functor f, MonadError e m) => MonadError e (FT f m) where throwError = lift . throwError {-# INLINE throwError #-} m `catchError` f = toFT $ fromFT m `catchError` (fromFT . f) instance MonadCont m => MonadCont (FT f m) where callCC f = join . lift $ callCC (\k -> return $ f (lift . k . return)) instance MonadReader r m => MonadReader r (FT f m) where ask = lift ask {-# INLINE ask #-} local f = hoistFT (local f) {-# INLINE local #-} instance (Functor f, MonadWriter w m) => MonadWriter w (FT f m) where tell = lift . tell {-# INLINE tell #-} listen = toFT . listen . fromFT pass = toFT . pass . fromFT #if MIN_VERSION_mtl(2,1,1) writer w = lift (writer w) {-# INLINE writer #-} #endif instance MonadState s m => MonadState s (FT f m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-} #if MIN_VERSION_mtl(2,1,1) state f = lift (state f) {-# INLINE state #-} #endif instance MonadThrow m => MonadThrow (FT f m) where throwM = lift . throwM {-# INLINE throwM #-} instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where catch m f = toFT $ fromFT m `Control.Monad.Catch.catch` (fromFT . f) {-# INLINE catch #-} -- | Generate a Church-encoded free monad transformer from a 'FreeT' monad -- transformer. toFT :: Monad m => FreeT f m a -> FT f m a toFT (FreeT f) = FT $ \ka kfr -> do freef <- f case freef of Pure a -> ka a Free fb -> kfr (\x -> runFT (toFT x) ka kfr) fb -- | Convert to a 'FreeT' free monad representation. fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a fromFT (FT k) = FreeT $ k (return . Pure) (\xg -> runFreeT . wrap . fmap (FreeT . xg)) -- | The \"free monad\" for a functor @f@. type F f = FT f Identity -- | Unwrap the 'Free' monad to obtain it's Church-encoded representation. runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r) runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (\xg -> return . kf . fmap (runIdentity . xg)) -- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor. free :: (forall r. (a -> r) -> (f r -> r) -> r) -> F f a free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf return)) -- | Tear down a free monad transformer using iteration. iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a iterT phi (FT m) = m return (\xg -> phi . fmap xg) {-# INLINE iterT #-} -- | Tear down a free monad transformer using iteration over a transformer. iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FT f m a -> t m a iterTM f (FT m) = join . lift $ m (return . return) (\xg -> return . f . fmap (join . lift . xg)) -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FT' f m@ to @'FT' f n@ -- -- @'hoistFT' :: ('Monad' m, 'Monad' n, 'Functor' f) => (m ~> n) -> 'FT' f m ~> 'FT' f n@ hoistFT :: (Monad m, Monad n) => (forall a. m a -> n a) -> FT f m b -> FT f n b hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (\xg -> return . kf (join . phi . xg))) -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@ transFT :: (forall a. f a -> g a) -> FT f m b -> FT g m b transFT phi (FT m) = FT (\kp kf -> m kp (\xg -> kf xg . phi)) -- | Pull out and join @m@ layers of @'FreeT' f m a@. joinFT :: (Monad m, Traversable f) => FT f m a -> m (F f a) joinFT (FT m) = m (return . return) (\xg -> liftM wrap . T.mapM xg) -- | Cuts off a tree of computations at a given depth. -- If the depth is 0 or less, no computation nor -- monadic effects will take place. -- -- Some examples (n ≥ 0): -- -- prop> cutoff 0 _ == return Nothing -- prop> cutoff (n+1) . return == return . Just -- prop> cutoff (n+1) . lift == lift . liftM Just -- prop> cutoff (n+1) . wrap == wrap . fmap (cutoff n) -- -- Calling 'retract . cutoff n' is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f, Monad m) => Integer -> FT f m a -> FT f m (Maybe a) cutoff n = toFT . FreeT.cutoff n . fromFT -- | -- 'retract' is the left inverse of 'liftF' -- -- @ -- 'retract' . 'liftF' = 'id' -- @ #if __GLASGOW_HASKELL__ < 710 retract :: (Functor f, Monad f) => F f a -> f a #else retract :: Monad f => F f a -> f a #endif retract m = runF m return join {-# INLINE retract #-} -- | Tear down a free monad transformer using iteration over a transformer. retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a retractT (FT m) = join . lift $ m (return . return) (\xg xf -> return $ xf >>= join . lift . xg) -- | Tear down an 'F' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> F f a -> a iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity) {-# INLINE iter #-} -- | Like 'iter' for monadic values. iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> F f a -> m a iterM phi = iterT phi . hoistFT (return . runIdentity) -- | Convert to another free monad representation. fromF :: (Functor f, MonadFree f m) => F f a -> m a fromF m = runF m return wrap {-# INLINE fromF #-} -- | Generate a Church-encoded free monad from a 'Free' monad. toF :: Free f a -> F f a toF = toFT {-# INLINE toF #-} -- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes. -- -- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett: -- -- -- -- -- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer: -- -- improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = fromF m {-# INLINE improve #-} -- | Improve the asymptotic performance of code that builds a free monad transformer -- with only binds and returns by using 'FT' behind the scenes. -- -- Similar to 'improve'. improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a improveT m = fromFT m {-# INLINE improveT #-}