free 4.12.4 → 5

raw patch · 31 files changed

+2419/−263 lines, 31 filesdep +faildep +transformers-basedep −prelude-extrasdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: fail, transformers-base

Dependencies removed: prelude-extras

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• .gitignore +17/−0
• .travis.yml +137/−33
• CHANGELOG.markdown +37/−0
• examples/LICENSE +30/−0
• examples/PerfTH.hs +125/−0
• examples/RetryTH.hs +2/−1
• examples/Teletype.lhs +2/−2
• examples/ValidationForm.hs +3/−2
• examples/free-examples.cabal +103/−0
• free.cabal +21/−4
• include/free-common.h +19/−0
• src/Control/Alternative/Free.hs +15/−13
• src/Control/Alternative/Free/Final.hs +3/−2
• src/Control/Applicative/Free.hs +15/−3
• src/Control/Applicative/Free/Fast.hs +168/−0
• src/Control/Applicative/Free/Final.hs +1/−3
• src/Control/Applicative/Trans/Free.hs +2/−0
• src/Control/Comonad/Cofree.hs +137/−22
• src/Control/Comonad/Cofree/Class.hs +1/−0
• src/Control/Comonad/Trans/Cofree.hs +0/−1
• src/Control/Comonad/Trans/Coiter.hs +61/−14
• src/Control/Monad/Free.hs +68/−31
• src/Control/Monad/Free/Ap.hs +433/−0
• src/Control/Monad/Free/Church.hs +36/−5
• src/Control/Monad/Free/Class.hs +1/−3
• src/Control/Monad/Free/TH.hs +120/−40
• src/Control/Monad/Trans/Free.hs +128/−36
• src/Control/Monad/Trans/Free/Ap.hs +590/−0
• src/Control/Monad/Trans/Free/Church.hs +20/−13
• src/Control/Monad/Trans/Iter.hs +81/−35
• src/Data/Functor/Classes/Compat.hs +43/−0

@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -13,3 +14,19 @@ *# .cabal-sandbox/ cabal.sandbox.config+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*

@@ -1,43 +1,147 @@-env:- - 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+# This Travis job script has been generated by a script via+#+#   runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+#+language: c+sudo: false +git:+  submodules: false  # whether to recursively clone submodules++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313free\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++cache:+  directories:+    - $HOME/.cabal/packages+    - $HOME/.cabal/store++before_cache:+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+  # remove files that are regenerated by 'cabal update'+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx++  - rm -rfv $HOME/.cabal/packages/head.hackage+ matrix:+  include:+    - compiler: "ghc-7.4.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+    - compiler: "ghc-7.6.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+    - compiler: "ghc-7.8.4"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+    - compiler: "ghc-7.10.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+    - compiler: "ghc-8.0.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.2.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.4.1"+      env: GHCHEAD=true+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}+    - compiler: "ghc-head"+      env: GHCHEAD=true+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}+   allow_failures:-   - env: GHCVER=head CABALVER=1.24+    - compiler: "ghc-8.4.1"+    - compiler: "ghc-head"  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+  - HC=${CC}+  - HCPKG=${HC/ghc/ghc-pkg}+  - unset CC+  - ROOTDIR=$(pwd)+  - mkdir -p $HOME/.local/bin+  - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"+  - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+  - echo $HCNUMVER  install:- - travis_retry cabal update- - cabal install --enable-tests --only-dependencies+  - cabal --version+  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+  - BENCH=${BENCH---enable-benchmarks}+  - TEST=${TEST---enable-tests}+  - HADDOCK=${HADDOCK-true}+  - INSTALLED=${INSTALLED-true}+  - GHCHEAD=${GHCHEAD-false}+  - travis_retry cabal update -v+  - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+  - rm -fv cabal.project cabal.project.local+  # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage+  - |+    if $GHCHEAD; then+      sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config +      echo 'repository head.hackage'                                                        >> ${HOME}/.cabal/config+      echo '   url: http://head.hackage.haskell.org/'                                       >> ${HOME}/.cabal/config+      echo '   secure: True'                                                                >> ${HOME}/.cabal/config+      echo '   root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config+      echo '              2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config+      echo '              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config+      echo '   key-threshold: 3'                                                            >> ${HOME}/.cabal.config++      cabal new-update head.hackage -v+    fi+  - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+  - "printf 'packages: \".\" \"./examples\"\\n' > cabal.project"+  - echo 'package free-examples' >> cabal.project+  - "echo '  flags: -mandelbrot-iter' >> cabal.project"+  - cat cabal.project+  - if [ -f "./configure.ac" ]; then+      (cd "." && autoreconf -i);+    fi+  - if [ -f "./examples/configure.ac" ]; then+      (cd "./examples" && autoreconf -i);+    fi+  - rm -f cabal.project.freeze+  - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all+  - rm -rf "."/.ghc.environment.* "./examples"/.ghc.environment.* "."/dist "./examples"/dist+  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)++# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail. 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+  # test that source-distributions can be generated+  - (cd "." && cabal sdist)+  - (cd "./examples" && cabal sdist)+  - mv "."/dist/free-*.tar.gz "./examples"/dist/free-examples-*.tar.gz ${DISTDIR}/+  - cd ${DISTDIR} || false+  - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;+  - "printf 'packages: free-*/*.cabal free-examples-*/*.cabal\\n' > cabal.project"+  - echo 'package free-examples' >> cabal.project+  - "echo '  flags: -mandelbrot-iter' >> cabal.project"+  - cat cabal.project -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"++  # build & run tests, build benchmarks+  - cabal new-build -w ${HC} ${TEST} ${BENCH} all++  # cabal check+  - (cd free-* && cabal check)+  - (cd free-examples-* && cabal check)++  # haddock+  - rm -rf ./dist-newstyle+  - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi++# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"]+# EOF

@@ -1,3 +1,40 @@+5 [2018.01.28]+--------------+* Add a `Semigroup` instance for `IterT`.+* Add `MonadFail` instances for `IterT` and `FreeT`.+* Add a `Comonad` instance for the free `Applicative`, `Ap`.+* Add `Control.Monad.Free.Ap` and `Control.Monad.Trans.Free.Ap` modules, based+  on the "Applicative Effects in Free Monads" series of articles by Will+  Fancher.+* Derive `Data` instances for `Free` and `Cofree`.+* `Control.Monad.Free.TH` now properly supports `template-haskell-2.11.0.0`. In+  particular, it now supports `GadtC` and `RecGadtC`, which are new+  `template-haskell` forms for representing GADTs.+* Add `telescoped_`, `shoots`, and `leaves` to `Control.Comonad.Cofree`+* Add the `Control.Applicative.Free.Fast` module, based on Dave Menendez's+  article "Free Applicative Functors in Haskell"+* Add `foldFreeT` to `Control.Monad.Trans.Free`+* Improve the `foldMap` and `cutoff` functions for+  `Control.Monad.Free.Church.F`, and add a `Traversable`+* Add a `MonadBase` instance for `FreeT`+* Add a performance test comparing Free and Church interpreters+* The use of `prelude-extras` has been removed. `free` now uses the+  `Data.Functor.Classes` module to give `free`'s datatypes instances of `Eq1`,+  `Ord1`, `Read1`, and `Show1`. Their `Eq`, `Ord`, `Read`, and `Show` instances+  have also been modified to incorporate these classes. For example, what+  previously existed as:++  ```haskell+  instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where+  ```++  has now been changed to:++  ```haskell+  instance (Eq1 f, Eq a) => Eq (Free f a) where+  ```+* Remove redundant `Functor` constraints from `Control.Alternative.Free`+ 4.12.4 ------ * Removed a number of spurious class constraints.

@@ -0,0 +1,30 @@+Copyright 2008-2013 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,125 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import System.CPUTime.Rdtsc+import System.IO+import System.IO.Unsafe+import Data.IORef+import Data.Word+import Control.Monad+import Control.Monad.State.Strict+import Control.Monad.Free+import Control.Monad.Free.TH+import qualified Control.Monad.Free.Church as Church+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Control.Category ((>>>))+import qualified Data.Foldable as F+import Text.Read.Compat (readMaybe)+import Text.Printf++-- | A data type representing basic commands for our performance-testing eDSL.+data PerfF next where+  Output    :: String -> next -> PerfF next+  Input     :: (Show a, Read a) => (a -> next) -> PerfF next++-- | Unfortunately this Functor instance cannot yet be derived+-- automatically by GHC.+instance Functor PerfF where+  fmap f (Output s x) = Output s (f x)+  fmap f (Input g) = Input (f . g)++makeFreeCon 'Output+makeFreeCon 'Input++type PerfCnt = Word64++-- | Unsafe state variable: base CPU cycles+{-# NOINLINE g_base_counter #-}+g_base_counter :: IORef PerfCnt+g_base_counter = unsafePerformIO $ do+  rdtsc >>= newIORef++-- | Prints number of CPU cycles since last call+g_print_time_since_prev_call :: (MonadIO m) => m ()+g_print_time_since_prev_call = liftIO $ do+  cb <- readIORef g_base_counter+  c <- rdtsc+  writeIORef g_base_counter c+  putStr $ printf "\r%-10s" (show $ c - cb)++-- | Free-based interpreter+runPerfFree :: (MonadIO m) => [String] -> Free PerfF () -> m ()+runPerfFree [] _ = return ()+runPerfFree (s:ss) x = case x of+  Free (Output o next) -> do+    runPerfFree (s:ss) next+  Free (Input next) -> do+    g_print_time_since_prev_call+    runPerfFree ss (next (read s))+  Pure a -> do+    return a++-- | Church-based interpreter+runPerfF :: (MonadIO m) => [String] -> Church.F PerfF () -> m ()+runPerfF [] _ = return ()+runPerfF ss0 f =+  fst `liftM` do+  flip runStateT ss0 $ Church.iterM go f where+    go (Output o next) = do+      next+    go (Input next) = do+      g_print_time_since_prev_call+      (s:ss) <- get+      put ss+      next (read s)++-- | Test input is the same for all cases+test_input = [show i | i<-([1..9999] ++ [0])]++-- | Tail-recursive program+test_tail :: (MonadFree PerfF m) => m ()+test_tail = do+  output "Enter something"+  (n :: Int) <- input+  output $ "Just entered: " ++ (show n)+  when (n > 0) $ do+    test_tail++run_tail_free,run_tail_f :: IO ()+run_tail_free = runPerfFree test_input test_tail+run_tail_f = runPerfF test_input test_tail+++-- | Deep-recursive program+test_loop :: (MonadFree PerfF m) => m ()+test_loop = do+  output "Enter something"+  (n :: Int) <- input+  when (n > 0) $ do+    test_loop+  output $ "Just entered: " ++ (show n)++run_loop_free,run_loop_f :: IO ()+run_loop_free = runPerfFree test_input test_loop+run_loop_f = runPerfF test_input test_loop++main :: IO ()+main = do+  putStr $ unlines [+      "Running two kinds of FreeMonad programs against two kinds of interpreters.",+      "Counters represent approx. number of CPU ticks per program iteration" ]+  putStrLn ">> (1/4) Tail-recursive program/Free interpreter"+  run_tail_free+  putStrLn "\n>> (2/4) Tail-recursive program/Church interpreter"+  run_tail_f+  putStrLn "\n>> (3/4) Deep-recursive program/Free interpreter (a slower one)"+  run_loop_free+  putStrLn "\n>> (4/4) Deep-recursive program/Church interpreter"+  run_loop_f+  putStrLn "\n"+

@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} module Main where@@ -9,7 +10,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import qualified Data.Foldable as F-import Text.Read (readMaybe)+import Text.Read.Compat (readMaybe)  -- | A data type representing basic commands for a retriable eDSL. data RetryF next where

@@ -1,12 +1,12 @@ > {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} -- +> import qualified Control.Exception as E (catch) > import Control.Monad         (mfilter) > import Control.Monad.Loops   (unfoldM) > import Control.Monad.Free    (liftF, Free, iterM, MonadFree) > import Control.Monad.Free.TH (makeFree) > import Control.Applicative   ((<$>)) > import System.IO             (isEOF)-> import Control.Exception     (catch) > import System.IO.Error       (ioeGetErrorString) > import System.Exit           (exitSuccess) @@ -61,7 +61,7 @@ >   run (ReadOrEOF eof f)         = isEOF >>= \b -> if b then eof >                                                        else getChar >>= f >->   run (ReadOrError ferror f)    = catch (getChar >>= f) (ferror . ioeGetErrorString)+>   run (ReadOrError ferror f)    = E.catch (getChar >>= f) (ferror . ioeGetErrorString) >   run (NL rest)                 = putChar '\n' >> rest >   run (rest :\^^ str)           = putStr str >> rest >   run ((:%) rest format tokens) = ttFormat format tokens >> rest

@@ -6,7 +6,7 @@  import Data.Monoid -import Text.Read (readEither)+import Text.Read.Compat (readEither) import Text.Printf  import System.IO@@ -66,8 +66,9 @@ -- 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)+input m = evalStateT (runAp inputField m) 1   where+    inputField :: Field a -> StateT Int IO a     inputField f@(Field n g h) = do       i <- get       -- get field input with prompt

@@ -0,0 +1,103 @@+name:          free-examples+category:      Control, Monads+version:       0.1+license:       BSD3+cabal-version: >= 1.18+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/free/+bug-reports:   http://github.com/ekmett/free/issues+copyright:     Copyright (C) 2008-2015 Edward A. Kmett+tested-with:   GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1+synopsis:      Monads for free+description:   Examples projects using @free@+build-type:    Simple++source-repository head+  type: git+  location: git://github.com/ekmett/free.git++flag mandelbrot-iter+  default: True+  manual:  True++library+  hs-source-dirs: .+  default-language: Haskell2010+  exposed-modules: Cabbage+  ghc-options: -Wall+  build-depends:+    base         == 4.*,+    free,+    mtl          >= 2.0.1 && < 2.3,+    transformers >= 0.2   && < 0.6++executable free-mandelbrot-iter+  if !flag(mandelbrot-iter)+    buildable: False+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: MandelbrotIter.lhs+  ghc-options: -Wall+  build-depends:+    base == 4.*,+    free,+    HGL,+    mtl  >= 2.0.1 && < 2.3++executable free-newton-coiter+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: NewtonCoiter.lhs+  ghc-options: -Wall+  build-depends:+    base    == 4.*,+    comonad >= 4 && < 6,+    free++executable free-perf-th+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: PerfTH.hs+  ghc-options: -Wall+  build-depends:+    base         == 4.*,+    base-compat,+    free,+    mtl          >= 2.0.1 && < 2.3,+    rdtsc,+    transformers >= 0.2   && < 0.6++executable free-retry-th+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: RetryTH.hs+  ghc-options: -Wall+  build-depends:+    base         == 4.*,+    base-compat,+    free,+    transformers >= 0.2 && < 0.6++executable free-teletype+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: Teletype.lhs+  ghc-options: -Wall+  build-depends:+    base == 4.*,+    free,+    monad-loops++executable free-validation-form+  hs-source-dirs: .+  default-language: Haskell2010+  main-is: ValidationForm.hs+  ghc-options: -Wall+  build-depends:+    base == 4.*,+    base-compat,+    free,+    mtl  >= 2.0.1 && < 2.3

@@ -1,8 +1,8 @@ name:          free category:      Control, Monads-version:       4.12.4+version:       5 license:       BSD3-cabal-version: >= 1.10+cabal-version: >= 1.18 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com>@@ -10,7 +10,7 @@ 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+tested-with:   GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 synopsis:      Monads for free description:   Free monads are useful for many tree-like structures and domain specific languages.@@ -43,8 +43,11 @@   HLint.hs   doc/proof/Control/Comonad/Cofree/*.md   doc/proof/Control/Comonad/Trans/Cofree/*.md+  examples/free-examples.cabal+  examples/LICENSE   examples/*.hs   examples/*.lhs+  include/free-common.h extra-doc-files:   examples/*.hs   examples/*.lhs@@ -55,6 +58,8 @@  library   hs-source-dirs: src+  include-dirs: include+  includes: free-common.h    default-language:   Haskell2010   default-extensions: CPP@@ -72,11 +77,11 @@     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-base    < 0.5,     transformers-compat  >= 0.3     && < 1,     template-haskell     >= 2.7.0.0 && < 3,     exceptions           >= 0.6 && < 0.9,@@ -84,6 +89,7 @@    exposed-modules:     Control.Applicative.Free+    Control.Applicative.Free.Fast     Control.Applicative.Free.Final     Control.Applicative.Trans.Free     Control.Alternative.Free@@ -93,11 +99,22 @@     Control.Comonad.Trans.Cofree     Control.Comonad.Trans.Coiter     Control.Monad.Free+    Control.Monad.Free.Ap     Control.Monad.Free.Church     Control.Monad.Free.Class     Control.Monad.Free.TH     Control.Monad.Trans.Free+    Control.Monad.Trans.Free.Ap     Control.Monad.Trans.Free.Church     Control.Monad.Trans.Iter +  other-modules:+    Data.Functor.Classes.Compat+   ghc-options: -Wall++  -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  else+    build-depends: fail == 4.9.*

@@ -0,0 +1,19 @@+#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++#if MIN_VERSION_base(4,9,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers(0,5,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)+#define LIFTED_FUNCTOR_CLASSES 1+#endif+#endif+#endif

@@ -6,6 +6,8 @@ {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-}+#include "free-common.h"+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Alternative.Free@@ -48,14 +50,14 @@   deriving Typeable #endif -instance Functor f => Functor (AltF f) where+instance 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+instance Functor (Alt f) where   fmap f (Alt xs) = Alt $ map (fmap f) xs -instance Functor f => Applicative (AltF f) where+instance Applicative (AltF f) where   pure = Pure   {-# INLINE pure #-}   (Pure f)   <*> y         = fmap f y      -- fmap@@ -63,7 +65,7 @@   (Ap a f)   <*> b         = a `Ap` (flip <$> f <*> (Alt [b]))   {-# INLINE (<*>) #-} -instance Functor f => Applicative (Alt f) where+instance Applicative (Alt f) where   pure a = Alt [pure a]   {-# INLINE pure #-} @@ -75,12 +77,12 @@       (u `Ap` f) `ap'` v  = Alt [u `Ap` (flip <$> f) <*> v]   {-# INLINE (<*>) #-} -liftAltF :: (Functor f) => f a -> AltF f a+liftAltF :: 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+-- | A version of 'lift' that can be used with any @f@.+liftAlt :: f a -> Alt f a liftAlt = Alt . (:[]) . liftAltF {-# INLINE liftAlt #-} @@ -96,28 +98,28 @@   go2 (Ap x f) = flip id <$> u x <*> go f {-# INLINABLE runAlt #-} -instance (Functor f) => Apply (Alt f) where+instance Apply (Alt f) where   (<.>) = (<*>)   {-# INLINE (<.>) #-} -instance (Functor f) => Alt.Alt (Alt f) where+instance Alt.Alt (Alt f) where   (<!>) = (<|>)   {-# INLINE (<!>) #-} -instance (Functor f) => Alternative (Alt f) where+instance Alternative (Alt f) where   empty = Alt []   {-# INLINE empty #-}   Alt as <|> Alt bs = Alt (as ++ bs)   {-# INLINE (<|>) #-} -instance (Functor f) => Semigroup (Alt f a) where+instance Semigroup (Alt f a) where   (<>) = (<|>)   {-# INLINE (<>) #-} -instance (Functor f) => Monoid (Alt f a) where+instance Monoid (Alt f a) where   mempty = empty   {-# INLINE mempty #-}-  mappend = (<|>)+  mappend = (<>)   {-# INLINE mappend #-}   mconcat as = Alt (as >>= alternatives)   {-# INLINE mconcat #-}

@@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Alternative.Free.Final@@ -24,7 +25,7 @@ import qualified Data.Functor.Alt as Alt import Data.Semigroup --- | The free 'Alternative' for a 'Functor' @f@.+-- | The free 'Alternative' for any @f@. newtype Alt f a = Alt { _runAlt :: forall g. Alternative g => (forall x. f x -> g x) -> g a }  instance Functor (Alt f) where@@ -49,7 +50,7 @@  instance Monoid (Alt f a) where   mempty = empty-  mappend = (<|>)+  mappend = (<>)  -- | A version of 'lift' that can be used with @f@. liftAlt :: f a -> Alt f a

@@ -5,10 +5,8 @@ {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-}+#include "free-common.h" -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Applicative.Free@@ -34,6 +32,7 @@   , runAp   , runAp_   , liftAp+  , iterAp   , hoistAp   , retractAp @@ -42,6 +41,7 @@   ) where  import Control.Applicative+import Control.Comonad (Comonad(..)) import Data.Functor.Apply import Data.Typeable @@ -88,10 +88,22 @@   Pure f <*> y = fmap f y   Ap x y <*> z = Ap x (flip <$> y <*> z) +instance Comonad f => Comonad (Ap f) where+  extract (Pure a) = a+  extract (Ap x y) = extract y (extract x)+  duplicate (Pure a) = Pure (Pure a)+  duplicate (Ap x y) = Ap (duplicate x) (extend (flip Ap) y)+   -- | A version of 'lift' that can be used with just a 'Functor' for @f@. liftAp :: f a -> Ap f a liftAp x = Ap x (Pure id) {-# INLINE liftAp #-}++-- | Tear down a free 'Applicative' using iteration.+iterAp :: Functor g => (g a -> a) -> Ap g a -> a+iterAp algebra = go+  where go (Pure a) = a+        go (Ap underlying apply) = algebra (go . (apply <*>) . pure <$> underlying)  -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b

@@ -0,0 +1,168 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE RankNTypes         #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# OPTIONS_GHC -Wall #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+--------------------------------------------------------------------------------+-- |+-- A faster free applicative.+-- Based on <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work>.+--------------------------------------------------------------------------------+module Control.Applicative.Free.Fast+  (+  -- * The Sequence of Effects+    ASeq(..)+  , reduceASeq+  , hoistASeq+  , traverseASeq+  , rebaseASeq+  -- * The Faster Free Applicative+  , Ap(..)+  , liftAp+  , retractAp+  , runAp+  , runAp_+  , hoistAp+  ) where++import           Control.Applicative+import           Data.Functor.Apply+import           Data.Typeable++#if !(MIN_VERSION_base(4,8,0))+import           Data.Monoid+#endif++-- | The free applicative is composed of a sequence of effects,+-- and a pure function to apply that sequence to.+-- The fast free applicative separates these from each other,+-- so that the sequence may be built up independently,+-- and so that 'fmap' can run in constant time by having immediate access to the pure function.+data ASeq f a where+  ANil :: ASeq f ()+  ACons :: f a -> ASeq f u -> ASeq f (a,u)+#if __GLASGOW_HASKELL__ >= 707+  deriving Typeable+#endif++-- | Interprets the sequence of effects using the semantics for+--   `pure` and `<*>` given by the Applicative instance for 'f'.+reduceASeq :: Applicative f => ASeq f u -> f u+reduceASeq ANil         = pure ()+reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs++-- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@.+hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a+hoistASeq _ ANil = ANil+hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs)++-- | Traverse a sequence with resepect to its interpretation type 'f'.+traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)+traverseASeq _ ANil      = pure ANil+traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f xs++-- | It may not be obvious, but this essentially acts like ++,+-- traversing the first sequence and creating a new one by appending the second sequence.+-- The difference is that this also has to modify the return functions and that the return type depends on the input types.+--+-- See the source of 'hoistAp' as an example usage.+rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) ->+  (v -> u -> y) -> ASeq f v -> z+rebaseASeq ANil         k f = k (\v -> f v ())+rebaseASeq (ACons x xs) k f =+  rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s))+    (\v u a -> f v (a,u))+++-- | The faster free 'Applicative'.+newtype Ap f a = Ap+  { unAp :: forall u y z.+    (forall x. (x -> y) -> ASeq f x -> z) ->+    (u -> a -> y) -> ASeq f u -> z }+#if __GLASGOW_HASKELL__ >= 707+  deriving Typeable+#endif++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp u = retractAp . hoistAp u++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)++instance Functor (Ap f) where+  fmap g x = Ap (\k f -> unAp x k (\s -> f s . g))++instance Apply (Ap f) where+  (<.>) = (<*>)++instance Applicative (Ap f) where+  pure a = Ap (\k f -> k (`f` a))+  x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a)))++-- | A version of 'lift' that can be used with just a 'Functor' for @f@.+liftAp :: f a -> Ap f a+liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s))+{-# INLINE liftAp #-}++-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.+hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a+hoistAp g x = Ap (\k f s ->+  unAp x+    (\f' s' ->+      rebaseASeq (hoistASeq g s') k+        (\v u -> f v (f' u)) s)+    (const id)+    ANil)++-- | Interprets the free applicative functor over f using the semantics for+--   `pure` and `<*>` given by the Applicative instance for f.+--+--   prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil++#if __GLASGOW_HASKELL__ < 707+instance Typeable1 f => Typeable1 (Ap f) where+  typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where+    f :: Ap f a -> f a+    f = undefined++apTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+apTyCon = mkTyCon "Control.Applicative.Free.Fast.Ap"+#else+apTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "Ap"+#endif+{-# NOINLINE apTyCon #-}++instance Typeable1 f => Typeable1 (ASeq f) where+  typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where+    f :: ASeq f a -> f a+    f = undefined++apSeqTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+apSeqTyCon = mkTyCon "Control.Applicative.Free.Fast.ASeq"+#else+apSeqTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "ASeq"+#endif+{-# NOINLINE apSeqTyCon #-}++#endif

@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-}+#include "free-common.h" -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Applicative.Free.Final

@@ -5,6 +5,8 @@ {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-}+#include "free-common.h"+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Applicative.Trans.Free

@@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-} #endif+#include "free-common.h" ----------------------------------------------------------------------------- -- | -- Module      :  Control.Comonad.Cofree@@ -33,6 +34,9 @@   , _extract   , _unwrap   , telescoped+  , telescoped_+  , shoots+  , leaves   ) where  import Control.Applicative@@ -47,6 +51,7 @@ import Control.Monad(ap, (>=>), liftM) import Control.Monad.Zip import Data.Functor.Bind+import Data.Functor.Classes.Compat import Data.Functor.Extend import Data.Data import Data.Distributive@@ -56,7 +61,6 @@ import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (id,(.))-import Prelude.Extras   infixr 5 :<@@ -99,11 +103,13 @@ -- -- In particular, if @f a ≡ [a]@, the -- resulting data structure is a <https://en.wikipedia.org/wiki/Rose_tree Rose tree>.--- For a practical application, check --- <https://personal.cis.strath.ac.uk/neil.ghani/papers/ghani-calco07 Higher Dimensional Trees, Algebraically> by Neil Ghani et al.+-- For a practical application, check+-- <https://web.archive.org/web/20161208002902/http://www.cs.le.ac.uk/people/ak155/Papers/CALCO-07/GK07.pdf Higher Dimensional Trees, Algebraically> by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a) #if __GLASGOW_HASKELL__ >= 707   deriving (Typeable)++deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a) #endif  -- | Use coiteration to generate a cofree comonad from a seed.@@ -193,49 +199,90 @@   (<*>) = ap   {-# INLINE (<*>) #-} +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f) => Show1 (Cofree f) where+  liftShowsPrec sp sl = go+    where+      goList = liftShowList sp sl+      go d (a :< as) = showParen (d > 5) $+        sp 6 a . showString " :< " . liftShowsPrec go goList 5 as+#else instance (Functor f, Show1 f) => Show1 (Cofree f) where   showsPrec1 d (a :< as) = showParen (d > 5) $     showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as)+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show a) => Show (Cofree f a) where+#else+instance (Functor f, Show1 f, Show a) => Show (Cofree f a) where+#endif+  showsPrec = showsPrec1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f) => Read1 (Cofree f) where+  liftReadsPrec rp rl = go+    where+      goList = liftReadList rp rl+      go d r = readParen (d > 5)+        (\r' -> [(u :< v, w) |+                (u, s) <- rp 6 r',+                (":<", t) <- lex s,+                (v, w) <- liftReadsPrec go goList 5 t]) r+#else instance (Functor f, Read1 f) => Read1 (Cofree f) where   readsPrec1 d r = readParen (d > 5)                           (\r' -> [(u :< fmap lower1 v,w) |                                   (u, s) <- readsPrec 6 r',                                   (":<", t) <- lex s,                                   (v, w) <- readsPrec1 5 t]) r+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read a) => Read (Cofree f a) where+#else+instance (Functor f, Read1 f, Read a) => Read (Cofree f a) where+#endif+  readsPrec = readsPrec1 -instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where-#ifndef HLINT-  a :< as == b :< bs = a == b && as == bs+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq a) => Eq (Cofree f a) where+#else+instance (Functor f, Eq1 f, Eq a) => Eq (Cofree f a) where #endif+  (==) = eq1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f) => Eq1 (Cofree f) where+  liftEq eq = go+    where+      go (a :< as) (b :< bs) = eq a b && liftEq go as bs+#else instance (Functor f, Eq1 f) => Eq1 (Cofree f) where #ifndef HLINT-  a :< as ==# b :< bs = a == b && fmap Lift1 as ==# fmap Lift1 bs+  eq1 (a :< as) (b :< bs) = a == b && eq1 (fmap Lift1 as) (fmap Lift1 bs) #endif+#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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord a) => Ord (Cofree f a) where+#else+instance (Functor f, Ord1 f, Ord a) => Ord (Cofree f a) where+#endif+  compare = compare1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f) => Ord1 (Cofree f) where+  liftCompare cmp = go+    where+      go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs+#else instance (Functor f, Ord1 f) => Ord1 (Cofree f) where   compare1 (a :< as) (b :< bs) = case compare a b of     LT -> LT     EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs)     GT -> GT+#endif  instance Foldable f => Foldable (Cofree f) where   foldMap f = go where@@ -366,3 +413,71 @@               (a -> f a) -> Cofree g a -> f (Cofree g a) telescoped = Prelude.foldr (\l r -> _unwrap . l . r) _extract {-# INLINE telescoped #-}++-- not actually named 'eats'+-- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor.+-- The only difference between this and 'telescoped' is that 'telescoped' focuses on a single value, but this focuses on the entire remaining subtree.+-- When the input list is empty, this is equivalent to 'id'.+-- When the input list is non-empty, this composes the input lenses+-- with '_unwrap' to walk through the @'Cofree' g@.+--+-- For more on lenses see the 'lens' package on hackage.+--+-- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)]      -> Lens' ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)]     -> Getter ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)]       -> Fold ('Cofree' g a) ('Cofree' g a)@+--+-- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)]    -> Setter' ('Cofree' g a) ('Cofree' g a)@+telescoped_ :: Functor f =>+              [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->+              (Cofree g a -> f (Cofree g a)) -> Cofree g a -> f (Cofree g a)+telescoped_ = Prelude.foldr (\l r -> _unwrap . l . r) id+{-# INLINE telescoped_ #-}++-- | A @Traversal'@ that gives access to all non-leaf @a@ elements of a+-- @'Cofree' g@ a, where non-leaf is defined as @x@ from @(x :< xs)@ where+-- @null xs@ is @False@.+--+-- Because this doesn't give access to all values in the @'Cofree' g@,+-- it cannot be used to change types.+--+-- @shoots :: Traversable g => Traversal' (Cofree g a) a@+--+-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to+-- use @null (toList xs)@ instead.+shoots :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)+shoots f = go+  where+#if __GLASGOW_HASKELL__ < 709+    go xxs@(x :< xs) | null (toList xs) = pure xxs+#else+    go xxs@(x :< xs) | null xs          = pure xxs+#endif+                     | otherwise        = (:<) <$> f x <*> traverse go xs+{-# INLINE shoots #-}++-- | A @Traversal'@ that gives access to all leaf @a@ elements of a+-- @'Cofree' g@ a, where leaf is defined as @x@ from @(x :< xs)@ where+-- @null xs@ is @True@.+--+-- Because this doesn't give access to all values in the @'Cofree' g@,+-- it cannot be used to change types.+--+-- @shoots :: Traversable g => Traversal' (Cofree g a) a@+--+-- N.B. On GHC < 7.9, this is slightly less flexible, as it has to+-- use @null (toList xs)@ instead.+leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)+leaves f = go+  where+#if __GLASGOW_HASKELL__ < 709+    go (x :< xs) | null (toList xs) = (:< xs) <$> f x+#else+    go (x :< xs) | null xs          = (:< xs) <$> f x+#endif+                 | otherwise        = (x :<) <$> traverse go xs+{-# INLINE leaves #-}

@@ -3,6 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}+#include "free-common.h" ----------------------------------------------------------------------------- -- | -- Module      :  Control.Comonad.Cofree.Class

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}

@@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif+#include "free-common.h"  ----------------------------------------------------------------------------- -- |@@ -58,11 +58,10 @@ import Data.Bitraversable import Data.Data import Data.Foldable-import Data.Function (on)+import Data.Functor.Classes.Compat 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) }@@ -70,19 +69,53 @@   deriving Typeable #endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 w) => Eq1 (CoiterT w) where+  liftEq eq = go+    where+      go (CoiterT x) (CoiterT y) = liftEq (liftEq2 eq go) x y+#else instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where-  (==#) = on (==#) (fmap (fmap Lift1) . runCoiterT)+  eq1 = on eq1 (fmap (fmap Lift1) . runCoiterT)+#endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 w) => Ord1 (CoiterT w) where+  liftCompare cmp = go+    where+      go (CoiterT x) (CoiterT y) = liftCompare (liftCompare2 cmp go) x y+#else instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where   compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT)+#endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 w) => Show1 (CoiterT w) where+  liftShowsPrec sp sl = go+    where+      goList = liftShowList sp sl+      go d (CoiterT x) = showsUnaryWith+        (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+        "CoiterT" d x     +#else instance (Functor w, Show1 w) => Show1 (CoiterT w) where   showsPrec1 d (CoiterT as) = showParen (d > 10) $     showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as)+#endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 w) => Read1 (CoiterT w) where+  liftReadsPrec rp rl = go+    where+      goList = liftReadList rp rl+      go = readsData $ readsUnaryWith+        (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+        "CoiterT" CoiterT+#else instance (Functor w, Read1 w) => Read1 (CoiterT w) where   readsPrec1 d =  readParen (d > 10) $ \r ->     [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+#endif  -- | The coiterative comonad type Coiter = CoiterT Identity@@ -147,20 +180,34 @@   {-# 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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 w, Show a) => Show (CoiterT w a) where+#else+instance (Functor w, Show1 w, Show a) => Show (CoiterT w a) where+#endif+  showsPrec = showsPrec1 -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]+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 w, Read a) => Read (CoiterT w a) where+#else+instance (Functor w, Read1 w, Read a) => Read (CoiterT w a) where+#endif+  readsPrec = readsPrec1 -instance Eq (w (a, CoiterT w a)) => Eq (CoiterT w a) where-  CoiterT a == CoiterT b = a == b+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 w, Eq a) => Eq (CoiterT w a) where+#else+instance (Functor w, Eq1 w, Eq a) => Eq (CoiterT w a) where+#endif+  (==) = eq1   {-# INLINE (==) #-} -instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where-  compare (CoiterT a) (CoiterT b) = compare a b+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 w, Ord a) => Ord (CoiterT w a) where+#else+instance (Functor w, Ord1 w, Ord a) => Ord (CoiterT w a) where+#endif+  compare = compare1   {-# INLINE compare #-}  -- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed.

@@ -1,15 +1,13 @@ {-# 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+{-# LANGUAGE StandaloneDeriving #-} #endif+#include "free-common.h" ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free@@ -52,6 +50,7 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind+import Data.Functor.Classes.Compat import Data.Foldable import Data.Profunctor import Data.Traversable@@ -59,7 +58,6 @@ import Data.Semigroup.Traversable import Data.Data import Prelude hiding (foldr)-import Prelude.Extras  -- | The 'Free' 'Monad' for a 'Functor' @f@. --@@ -108,42 +106,83 @@ data Free f a = Pure a | Free (f (Free f a)) #if __GLASGOW_HASKELL__ >= 707   deriving (Typeable)++deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a) #endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance Eq1 f => Eq1 (Free f) where+  liftEq eq = go+    where+      go (Pure a)  (Pure b)  = eq a b+      go (Free fa) (Free fb) = liftEq go fa fb+      go _ _                 = False+#else instance (Functor f, Eq1 f) => Eq1 (Free f) where-  Pure a  ==# Pure b  = a == b-  Free fa ==# Free fb = fmap Lift1 fa ==# fmap Lift1 fb-  _       ==# _ = False+  Pure a  `eq1` Pure b  = a == b+  Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb+  _       `eq1` _ = False+#endif -instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where-  Pure a == Pure b = a == b-  Free fa == Free fb = fa == fb-  _ == _ = False+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq a) => Eq (Free f a) where+#else+instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where+#endif+  (==) = eq1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance Ord1 f => Ord1 (Free f) where+  liftCompare cmp = go+    where+      go (Pure a)  (Pure b)  = cmp a b+      go (Pure _)  (Free _)  = LT+      go (Free _)  (Pure _)  = GT+      go (Free fa) (Free fb) = liftCompare go fa fb+#else instance (Functor f, Ord1 f) => Ord1 (Free f) where   Pure a `compare1` Pure b = a `compare` b   Pure _ `compare1` Free _ = LT   Free _ `compare1` Pure _ = GT   Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord a) => Ord (Free f a) where+#else+instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where+#endif+  compare = compare1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance Show1 f => Show1 (Free f) where+  liftShowsPrec sp sl = go+    where+      go d (Pure a) = showsUnaryWith sp "Pure" d a+      go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa+#else instance (Functor f, Show1 f) => Show1 (Free f) where   showsPrec1 d (Pure a) = showParen (d > 10) $     showString "Pure " . showsPrec 11 a   showsPrec1 d (Free m) = showParen (d > 10) $     showString "Free " . showsPrec1 11 (fmap Lift1 m)+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show a) => Show (Free f a) where+#else+instance (Show1 f, Functor f, Show a) => Show (Free f a) where+#endif+  showsPrec = showsPrec1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance Read1 f => Read1 (Free f) where+  liftReadsPrec rp rl = go+    where+      go = readsData $+        readsUnaryWith rp "Pure" Pure `mappend`+        readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free+#else instance (Functor f, Read1 f) => Read1 (Free f) where   readsPrec1 d r = readParen (d > 10)       (\r' -> [ (Pure m, t)@@ -153,16 +192,14 @@       (\r' -> [ (Free (fmap lower1 m), t)              | ("Free", s) <- lex r'              , (m, t) <- readsPrec1 11 s]) r+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read a) => Read (Free f a) where+#else+instance (Read1 f, Functor f, Read a) => Read (Free f a) where+#endif+  readsPrec = readsPrec1  instance Functor f => Functor (Free f) where   fmap f = go where

@@ -0,0 +1,433 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#include "free-common.h"++--------------------------------------------------------------------------------+-- |+-- \"Applicative Effects in Free Monads\"+--+-- Often times, the '(<*>)' operator can be more efficient than 'ap'.+-- Conventional free monads don't provide any means of modeling this.+-- The free monad can be modified to make use of an underlying applicative.+-- But it does require some laws, or else the '(<*>)' = 'ap' law is broken.+-- When interpreting this free monad with 'foldFree',+-- the natural transformation must be an applicative homomorphism.+-- An applicative homomorphism @hm :: (Applicative f, Applicative g) => f x -> g x@+-- will satisfy these laws.+--+-- * @hm (pure a) = pure a@+-- * @hm (f <*> a) = hm f <*> hm a@+--+-- This is based on the \"Applicative Effects in Free Monads\" series of articles by Will Fancher+--+-- * <http://elvishjerricco.github.io/2016/04/08/applicative-effects-in-free-monads.html Applicative Effects in Free Monads>+--+-- * <http://elvishjerricco.github.io/2016/04/13/more-on-applicative-effects-in-free-monads.html More on Applicative Effects in Free Monads>+--------------------------------------------------------------------------------+module Control.Monad.Free.Ap+  ( MonadFree(..)+  , Free(..)+  , retract+  , liftF+  , iter+  , iterA+  , iterM+  , hoistFree+  , foldFree+  , toFreeT+  , cutoff+  , unfold+  , unfoldM+  , _Pure, _Free+  ) where++import Control.Applicative+import Control.Arrow ((>>>))+import Control.Monad (liftM, MonadPlus(..), (>=>))+import Control.Monad.Fix+import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.Free.Ap as FreeT+import Control.Monad.Free.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind+import Data.Functor.Classes.Compat+import Data.Foldable+import Data.Profunctor+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Data+import Prelude hiding (foldr)++-- | A free monad given an applicative+data Free f a = Pure a | Free (f (Free f a))+#if __GLASGOW_HASKELL__ >= 707+  deriving (Typeable)+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance Eq1 f => Eq1 (Free f) where+  liftEq eq = go+    where+      go (Pure a)  (Pure b)  = eq a b+      go (Free fa) (Free fb) = liftEq go fa fb+      go _ _                 = False+#else+instance (Functor f, Eq1 f) => Eq1 (Free f) where+  Pure a  `eq1` Pure b  = a == b+  Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb+  _       `eq1` _ = False+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq a) => Eq (Free f a) where+#else+instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where+#endif+  (==) = eq1++#ifdef LIFTED_FUNCTOR_CLASSES+instance Ord1 f => Ord1 (Free f) where+  liftCompare cmp = go+    where+      go (Pure a)  (Pure b)  = cmp a b+      go (Pure _)  (Free _)  = LT+      go (Free _)  (Pure _)  = GT+      go (Free fa) (Free fb) = liftCompare go fa fb+#else+instance (Functor f, Ord1 f) => Ord1 (Free f) where+  Pure a `compare1` Pure b = a `compare` b+  Pure _ `compare1` Free _ = LT+  Free _ `compare1` Pure _ = GT+  Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord a) => Ord (Free f a) where+#else+instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where+#endif+  compare = compare1++#ifdef LIFTED_FUNCTOR_CLASSES+instance Show1 f => Show1 (Free f) where+  liftShowsPrec sp sl = go+    where+      go d (Pure a) = showsUnaryWith sp "Pure" d a+      go d (Free fa) = showsUnaryWith (liftShowsPrec go (liftShowList sp sl)) "Free" d fa+#else+instance (Functor f, Show1 f) => Show1 (Free f) where+  showsPrec1 d (Pure a) = showParen (d > 10) $+    showString "Pure " . showsPrec 11 a+  showsPrec1 d (Free m) = showParen (d > 10) $+    showString "Free " . showsPrec1 11 (fmap Lift1 m)+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show a) => Show (Free f a) where+#else+instance (Show1 f, Functor f, Show a) => Show (Free f a) where+#endif+  showsPrec = showsPrec1++#ifdef LIFTED_FUNCTOR_CLASSES+instance Read1 f => Read1 (Free f) where+  liftReadsPrec rp rl = go+    where+      go = readsData $+        readsUnaryWith rp "Pure" Pure `mappend`+        readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "Free" Free+#else+instance (Functor f, Read1 f) => Read1 (Free f) where+  readsPrec1 d r = readParen (d > 10)+      (\r' -> [ (Pure m, t)+             | ("Pure", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Free (fmap lower1 m), t)+             | ("Free", s) <- lex r'+             , (m, t) <- readsPrec1 11 s]) r+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read a) => Read (Free f a) where+#else+instance (Read1 f, Functor f, Read a) => Read (Free f a) where+#endif+  readsPrec = readsPrec1++instance Functor f => Functor (Free f) where+  fmap f = go where+    go (Pure a)  = Pure (f a)+    go (Free fa) = Free (go <$> fa)+  {-# INLINE fmap #-}++instance Apply f => Apply (Free f) where+  Pure a  <.> Pure b = Pure (a b)+  Pure a  <.> Free fb = Free $ fmap a <$> fb+  Free fa <.> Pure b = Free $ fmap ($ b) <$> fa+  Free fa <.> Free fb = Free $ fmap (<.>) fa <.> fb++instance Applicative f => Applicative (Free f) where+  pure = Pure+  {-# INLINE pure #-}+  Pure a <*> Pure b = Pure $ a b+  Pure a <*> Free mb = Free $ fmap a <$> mb+  Free ma <*> Pure b = Free $ fmap ($ b) <$> ma+  Free ma <*> Free mb = Free $ fmap (<*>) ma <*> mb++instance Apply f => Bind (Free f) where+  Pure a >>- f = f a+  Free m >>- f = Free ((>>- f) <$> m)++instance Applicative f => Monad (Free f) where+  return = pure+  {-# INLINE return #-}+  Pure a >>= f = f a+  Free m >>= f = Free ((>>= f) <$> m)++instance Applicative f => MonadFix (Free f) where+  mfix f = a where a = f (impure a); impure (Pure x) = x; impure (Free _) = error "mfix (Free f): Free"++-- | This violates the Alternative laws, handle with care.+instance Alternative v => Alternative (Free v) where+  empty = Free empty+  {-# INLINE empty #-}+  a <|> b = Free (pure a <|> pure b)+  {-# INLINE (<|>) #-}++-- | This violates the MonadPlus laws, handle with care.+instance (Applicative v, MonadPlus v) => MonadPlus (Free v) where+  mzero = Free mzero+  {-# INLINE mzero #-}+  a `mplus` b = Free (return a `mplus` return b)+  {-# INLINE mplus #-}++-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\".+instance MonadTrans Free where+  lift = Free . liftM Pure+  {-# INLINE lift #-}++instance Foldable f => Foldable (Free f) where+  foldMap f = go where+    go (Pure a) = f a+    go (Free fa) = foldMap go fa+  {-# INLINE foldMap #-}++  foldr f = go where+    go r free =+      case free of+        Pure a -> f a r+        Free fa -> foldr (flip go) r fa+  {-# INLINE foldr #-}++#if MIN_VERSION_base(4,6,0)+  foldl' f = go where+    go r free =+      case free of+        Pure a -> f r a+        Free fa -> foldl' go r fa+  {-# INLINE foldl' #-}+#endif++instance Foldable1 f => Foldable1 (Free f) where+  foldMap1 f = go where+    go (Pure a) = f a+    go (Free fa) = foldMap1 go fa+  {-# INLINE foldMap1 #-}++instance Traversable f => Traversable (Free f) where+  traverse f = go where+    go (Pure a) = Pure <$> f a+    go (Free fa) = Free <$> traverse go fa+  {-# INLINE traverse #-}++instance Traversable1 f => Traversable1 (Free f) where+  traverse1 f = go where+    go (Pure a) = Pure <$> f a+    go (Free fa) = Free <$> traverse1 go fa+  {-# INLINE traverse1 #-}++instance (Applicative m, MonadWriter e m) => MonadWriter e (Free m) where+  tell = lift . tell+  {-# INLINE tell #-}+  listen = lift . listen . retract+  {-# INLINE listen #-}+  pass = lift . pass . retract+  {-# INLINE pass #-}++instance (Applicative m, MonadReader e m) => MonadReader e (Free m) where+  ask = lift ask+  {-# INLINE ask #-}+  local f = lift . local f . retract+  {-# INLINE local #-}++instance (Applicative m, MonadState s m) => MonadState s (Free m) where+  get = lift get+  {-# INLINE get #-}+  put s = lift (put s)+  {-# INLINE put #-}++instance (Applicative m, MonadError e m) => MonadError e (Free m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}+  catchError as f = lift (catchError (retract as) (retract . f))+  {-# INLINE catchError #-}++instance (Applicative m, MonadCont m) => MonadCont (Free m) where+  callCC f = lift (callCC (retract . f . liftM lift))+  {-# INLINE callCC #-}++instance Applicative f => MonadFree f (Free f) where+  wrap = Free+  {-# INLINE wrap #-}++-- |+-- 'retract' is the left inverse of 'lift' and 'liftF'+--+-- @+-- 'retract' . 'lift' = 'id'+-- 'retract' . 'liftF' = 'id'+-- @+retract :: (Applicative f, Monad f) => Free f a -> f a+retract = foldFree id++-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.+iter :: Applicative f => (f a -> a) -> Free f a -> a+iter _ (Pure a) = a+iter phi (Free m) = phi (iter phi <$> m)++-- | Like 'iter' for applicative values.+iterA :: (Applicative p, Applicative f) => (f (p a) -> p a) -> Free f a -> p a+iterA _   (Pure x) = pure x+iterA phi (Free f) = phi (iterA phi <$> f)++-- | Like 'iter' for monadic values.+iterM :: (Applicative m, Monad m, Applicative f) => (f (m a) -> m a) -> Free f a -> m a+iterM _   (Pure x) = return x+iterM phi (Free f) = phi (iterM phi <$> f)++-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'Free' f@ to @'Free' g@.+hoistFree :: (Applicative f, Applicative g) => (forall a. f a -> g a) -> Free f b -> Free g b+hoistFree f = foldFree (liftF . f)++-- | Given an applicative homomorphism, you get a monad homomorphism.+foldFree :: (Applicative f, Applicative m, Monad m) => (forall x . f x -> m x) -> Free f a -> m a+foldFree _ (Pure a)  = return a+foldFree f (Free as) = f as >>= foldFree f++-- | Convert a 'Free' monad from "Control.Monad.Free.Ap" to a 'FreeT.FreeT' monad+-- from "Control.Monad.Trans.Free.Ap".+-- WARNING: This assumes that 'liftF' is an applicative homomorphism.+toFreeT :: (Applicative f, Applicative m, Monad m) => Free f a -> FreeT.FreeT f m a+toFreeT = foldFree liftF++-- | Cuts off a tree of computations at a given depth.+-- If the depth is 0 or less, no computation nor+-- monadic effects will take place.+--+-- Some examples (n ≥ 0):+--+-- prop> cutoff 0     _        == return Nothing+-- prop> cutoff (n+1) . return == return . Just+-- prop> cutoff (n+1) . lift   ==   lift . liftM Just+-- prop> cutoff (n+1) . wrap   ==  wrap . fmap (cutoff n)+--+-- Calling 'retract . cutoff n' is always terminating, provided each of the+-- steps in the iteration is terminating.+cutoff :: (Applicative f) => Integer -> Free f a -> Free f (Maybe a)+cutoff n _ | n <= 0 = return Nothing+cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f+cutoff _ m = Just <$> m++-- | Unfold a free monad from a seed.+unfold :: Applicative f => (b -> Either a (f b)) -> b -> Free f a+unfold f = f >>> either Pure (Free . fmap (unfold f))++-- | Unfold a free monad from a seed, monadically.+unfoldM :: (Applicative f, Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)+unfoldM f = f >=> either (pure . pure) (fmap Free . traverse (unfoldM f))++-- | This is @Prism' (Free f a) a@ in disguise+--+-- >>> preview _Pure (Pure 3)+-- Just 3+--+-- >>> review _Pure 3 :: Free Maybe Int+-- Pure 3+_Pure :: forall f m a p. (Choice p, Applicative m)+      => p a (m a) -> p (Free f a) (m (Free f a))+_Pure = dimap impure (either pure (fmap Pure)) . right'+ where+  impure (Pure x) = Right x+  impure x        = Left x+  {-# INLINE impure #-}+{-# INLINE _Pure #-}++-- | This is @Prism' (Free f a) (f (Free f a))@ in disguise+--+-- >>> preview _Free (review _Free (Just (Pure 3)))+-- Just (Just (Pure 3))+--+-- >>> review _Free (Just (Pure 3))+-- Free (Just (Pure 3))+_Free :: forall f m a p. (Choice p, Applicative m)+      => p (f (Free f a)) (m (f (Free f a))) -> p (Free f a) (m (Free f a))+_Free = dimap unfree (either pure (fmap Free)) . right'+ where+  unfree (Free x) = Right x+  unfree x        = Left x+  {-# INLINE unfree #-}+{-# INLINE _Free #-}+++#if __GLASGOW_HASKELL__ < 707+instance Typeable1 f => Typeable1 (Free f) where+  typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where+    f :: Free f a -> f a+    f = undefined++freeTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+freeTyCon = mkTyCon "Control.Monad.Free.Free"+#else+freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free"+#endif+{-# NOINLINE freeTyCon #-}++instance+  ( Typeable1 f, Typeable a+  , Data a, Data (f (Free f a))+  ) => Data (Free f a) where+    gfoldl f z (Pure a) = z Pure `f` a+    gfoldl f z (Free as) = z Free `f` as+    toConstr Pure{} = pureConstr+    toConstr Free{} = freeConstr+    gunfold k z c = case constrIndex c of+        1 -> k (z Pure)+        2 -> k (z Free)+        _ -> error "gunfold"+    dataTypeOf _ = freeDataType+    dataCast1 f = gcast1 f++pureConstr, freeConstr :: Constr+pureConstr = mkConstr freeDataType "Pure" [] Prefix+freeConstr = mkConstr freeDataType "Free" [] Prefix+{-# NOINLINE pureConstr #-}+{-# NOINLINE freeConstr #-}++freeDataType :: DataType+freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr]+{-# NOINLINE freeDataType #-}++#endif

@@ -4,9 +4,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif+#include "free-common.h"+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free.Church@@ -71,14 +70,16 @@ 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.Traversable import Data.Functor.Bind+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable import Prelude hiding (foldr)  -- | The Church-encoded free monad for a functor @f@.@@ -124,6 +125,9 @@     impure (F x) = x id (error "MonadFix (F f): wrap")  instance Foldable f => Foldable (F f) where+    foldMap f xs = runF xs f fold+    {-# INLINE foldMap #-}+     foldr f r xs = runF xs f (foldr (.) id) r     {-# INLINE foldr #-} @@ -132,6 +136,16 @@     {-# INLINE foldl' #-} #endif +instance Traversable f => Traversable (F f) where+    traverse f m = runF m (fmap return . f) (fmap wrap . sequenceA)+    {-# INLINE traverse #-}++instance Foldable1 f => Foldable1 (F f) where+    foldMap1 f m = runF m f fold1++instance Traversable1 f => Traversable1 (F f) where+    traverse1 f m = runF m (fmap return . f) (fmap wrap . sequence1)+ -- | This violates the MonadPlus laws, handle with care. instance MonadPlus f => MonadPlus (F f) where   mzero = F (\_ kf -> kf mzero)@@ -216,6 +230,23 @@ -- -- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating.+{-# INLINE cutoff #-} cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a)-cutoff n = toF . Free.cutoff n . fromF+cutoff n m+    | n <= 0 = return Nothing+    | n <= toInteger (maxBound :: Int) = cutoffI (fromInteger n :: Int) m+    | otherwise = cutoffI n m +{-# SPECIALIZE cutoffI :: (Functor f) => Int -> F f a -> F f (Maybe a) #-}+{-# SPECIALIZE cutoffI :: (Functor f) => Integer -> F f a -> F f (Maybe a) #-}+cutoffI :: (Functor f, Integral n) => n -> F f a -> F f (Maybe a)+cutoffI n m = F m' where+    m' kp kf = runF m kpn kfn n where+        kpn a i+            | i <= 0 = kp Nothing+            | otherwise = kp (Just a)+        kfn fr i+            | i <= 0 = kp Nothing+            | otherwise = let+                i' = i - 1+                in i' `seq` kf (fmap ($ i') fr)

@@ -8,10 +8,8 @@ {-# LANGUAGE TypeFamilies #-} #endif {-# OPTIONS_GHC -fno-warn-deprecations #-}+#include "free-common.h" -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free.Class

@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif+#include "free-common.h"  ----------------------------------------------------------------------------- -- |@@ -35,7 +32,9 @@ import Control.Arrow import Control.Monad import Data.Char (toLower)+import Data.List ((\\), nub) import Language.Haskell.TH+import Language.Haskell.TH.Syntax  #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative@@ -77,7 +76,7 @@ mkOpName :: String -> Q String mkOpName (':':name) = return name mkOpName ( c :name) = return $ toLower c : name-mkOpName _ = fail "null constructor name"+mkOpName _ = fail "impossible happened: empty (null) constructor name"  -- | Check if parameter is used in type. usesTV :: Name -> Type -> Bool@@ -88,8 +87,8 @@ usesTV _ _ = False  -- | Analyze constructor argument.-mkArg :: Name -> Type -> Q Arg-mkArg n t+mkArg :: Type -> Type -> Q Arg+mkArg (VarT n) t   | usesTV n t =       case t of         -- if parameter is used as is, the return type should be ()@@ -100,19 +99,38 @@         -- expression is an N-tuple secion (,...,).         AppT (AppT ArrowT _) _ -> do           (ts, name) <- arrowsToTuple t-          when (name /= n) $ fail "return type is not the parameter"+          when (any (usesTV n) ts) $ fail $ unlines+            [ "type variable " ++ pprint n ++ " is forbidden"+            , "in a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")"+            , "in a constructor's argument type: " ++ pprint t ]+          when (name /= n) $ fail $ unlines+            [ "expected final return type `" ++ pprint n ++ "'"+            , "but got `" ++ pprint name ++ "'"+            , "in a constructor's argument type: `" ++ pprint t ++ "'" ]           let tup = 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"+        _ -> fail $ unlines+              [ "expected a type variable `" ++ pprint n ++ "'"+              , "or a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")"+              , "but got `" ++ pprint t ++ "'"+              , "in a constructor's argument" ]   | otherwise = return $ Param t   where-    arrowsToTuple (AppT (AppT ArrowT t1) (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"+    arrowsToTuple (VarT name) = return ([], name)+    arrowsToTuple rt = fail $ unlines+      [ "expected final return type `" ++ pprint n ++ "'"+      , "but got `" ++ pprint rt ++ "'"+      , "in a constructor's argument type: `" ++ pprint t ++ "'" ] +mkArg n _ = fail $ unlines+  [ "expected a type variable"+  , "but got `" ++ pprint n ++ "'"+  , "as the last parameter of the type constructor" ]+ -- | Apply transformation to the return value independently of how many -- parameters does @e@ have. -- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to@@ -144,9 +162,32 @@ 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"+unifyCaptured _ xs = fail $ unlines+  [ "can't unify more than 2 return types"+  , "that use type parameter"+  , "when unifying return types: "+  , unlines (map (pprint . fst) xs) ] -liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]+extractVars :: Type -> [Name]+extractVars (ForallT bs _ t) = extractVars t \\ map bndrName bs+  where+    bndrName (PlainTV n) = n+    bndrName (KindedTV n _) = n+extractVars (VarT n) = [n]+extractVars (AppT x y) = extractVars x ++ extractVars y+#if MIN_VERSION_template_haskell(2,8,0)+extractVars (SigT x k) = extractVars x ++ extractVars k+#else+extractVars (SigT x k) = extractVars x+#endif+#if MIN_VERSION_template_haskell(2,11,0)+extractVars (InfixT x _ y) = extractVars x ++ extractVars y+extractVars (UInfixT x _ y) = extractVars x ++ extractVars y+extractVars (ParensT x) = extractVars x+#endif+extractVars _ = []++liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec] liftCon' typeSig tvbs cx f n ns cn ts = do   -- prepare some names   opName <- mkName <$> mkOpName (nameBase cn)@@ -168,9 +209,10 @@   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)+      ns' = nub (concatMap extractVars ns)+      q = filter nonNext tvbs ++ map PlainTV (qa ++ m : ns')       qa = case retType of VarT b | a == b -> [a]; _ -> []-      f' = foldl AppT f (map VarT ns)+      f' = foldl AppT f ns   return $ concat     [ if typeSig #if MIN_VERSION_template_haskell(2,10,0)@@ -180,17 +222,61 @@ #endif         else []     , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ]+  where+    nonNext (PlainTV pn) = VarT pn /= n+    nonNext (KindedTV kn _) = VarT kn /= n  -- | 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"+liftCon :: Bool -> [TyVarBndr] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec]+liftCon typeSig ts cx f n ns onlyCons con+  | not (any (`melem` onlyCons) (constructorNames con)) = return []+  | otherwise = case con of+      NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields+      RecC    cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields+      InfixC  (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2]+      ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns onlyCons con'+#if MIN_VERSION_template_haskell(2,11,0)+      GadtC cNames fields resType -> do+        decs <- forM (filter (`melem` onlyCons) cNames) $ \cName ->+                  liftGadtC cName fields resType typeSig ts cx f+        return (concat decs)+      RecGadtC cNames fields resType -> do+        let fields' = map (\(_, x, y) -> (x, y)) fields+        decs <- forM (filter (`melem` onlyCons) cNames) $ \cName ->+                  liftGadtC cName fields' resType typeSig ts cx f+        return (concat decs)+#endif+      _ -> fail $ "Unsupported constructor type: `" ++ pprint con ++ "'" +#if MIN_VERSION_template_haskell(2,11,0)+splitAppT :: Type -> [Type]+splitAppT (AppT x y) = splitAppT x ++ [y]+splitAppT t = [t]++liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndr] -> Cxt -> Type -> Q [Dec]+liftGadtC cName fields resType typeSig ts cx f =+  liftCon typeSig ts cx f nextTy (init tys) Nothing (NormalC cName fields)+  where+    (_f : tys) = splitAppT resType+    nextTy = last tys+#endif++melem :: Eq a => a -> Maybe [a] -> Bool+melem _ Nothing   = True+melem x (Just xs) = x `elem` xs++-- | Get construstor name(s).+constructorNames :: Con -> [Name]+constructorNames (NormalC  name _)    = [name]+constructorNames (RecC     name _)    = [name]+constructorNames (InfixC   _ name _)  = [name]+constructorNames (ForallC  _ _ c)     = constructorNames c+#if MIN_VERSION_template_haskell(2,11,0)+constructorNames (GadtC names _ _)    = names+constructorNames (RecGadtC names _ _) = names+#endif+constructorNames con' = fail $ "Unsupported constructor type: `" ++ pprint con' ++ "'"+ -- | Provide free monadic actions for a type declaration. liftDec :: Bool             -- ^ Include type signature?         -> Maybe [Name]     -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.@@ -201,24 +287,16 @@ #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'+  | null tyVarBndrs = fail $ "Type constructor " ++ pprint tyName ++ " needs at least one type parameter"+  | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTy (init tys) onlyCons) cons     where-      cons' = case onlyCons of-                Nothing -> cons-                Just ns -> filter (\c -> constructorName c `elem` ns) cons-      tyNames    = map tyVarBndrName tyVarBndrs-      nextTyName = last tyNames+      tys     = map (VarT . tyVarBndrName) tyVarBndrs+      nextTy  = last tys       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"+liftDec _ _ dec = fail $ unlines+  [ "failed to derive makeFree operations:"+  , "expected a data type constructor"+  , "but got " ++ pprint dec ]  -- | Generate monadic actions for a data type. genFree :: Bool         -- ^ Include type signature?@@ -243,7 +321,9 @@                        _ #endif                          -> genFree typeSig (Just [cname]) tname-    _ -> fail "makeFreeCon expects a data constructor"+    _ -> fail $ unlines+          [ "expected a data constructor"+          , "but got " ++ pprint info ]  -- | @$('makeFree' ''T)@ provides free monadic actions for the -- constructors of the given data type @T@.

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -8,14 +7,8 @@ #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif+#include "free-common.h" -#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Free@@ -42,6 +35,7 @@   , iterT   , iterTM   , hoistFreeT+  , foldFreeT   , transFreeT   , joinFreeT   , cutoff@@ -59,9 +53,11 @@  import Control.Applicative import Control.Monad (liftM, MonadPlus(..), ap, join)+import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class import Control.Monad.Free.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class@@ -69,15 +65,14 @@ import Control.Monad.Error.Class import Control.Monad.Cont.Class import Data.Functor.Bind hiding (join)+import Data.Functor.Classes.Compat 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@@ -91,15 +86,32 @@ #endif            ) +#ifdef LIFTED_FUNCTOR_CLASSES 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+  liftShowsPrec2 spa _sla _spb _slb d (Pure a) =+    showsUnaryWith spa "Pure" d a +  liftShowsPrec2 _spa _sla spb slb d (Free as) =+    showsUnaryWith (liftShowsPrec spb slb) "Free" d as  instance (Show1 f, Show a) => Show1 (FreeF f a) where-  showsPrec1 = showsPrec2+  liftShowsPrec = liftShowsPrec2 showsPrec showList+#else+instance (Show1 f, Show a) => Show1 (FreeF f a) where+  showsPrec1 d (Pure a)  = showParen (d > 10) $ showString "Pure " . showsPrec 11 a+  showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as+#endif +#ifdef LIFTED_FUNCTOR_CLASSES instance Read1 f => Read2 (FreeF f) where-  readsPrec2 d r = readParen (d > 10)+  liftReadsPrec2 rpa _rla rpb rlb = readsData $+    readsUnaryWith rpa "Pure" Pure `mappend`+    readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free++instance (Read1 f, Read a) => Read1 (FreeF f a) where+  liftReadsPrec = liftReadsPrec2 readsPrec readList+#else+instance (Read1 f, Read a) => Read1 (FreeF f a) where+  readsPrec1 d r = readParen (d > 10)       (\r' -> [ (Pure m, t)              | ("Pure", s) <- lex r'              , (m, t) <- readsPrec 11 s]) r@@ -107,26 +119,39 @@       (\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+#endif +#ifdef LIFTED_FUNCTOR_CLASSES instance Eq1 f => Eq2 (FreeF f) where-  Pure a  ==## Pure b = a == b-  Free as ==## Free bs = as ==# bs-  _       ==## _ = False+  liftEq2 eq _ (Pure a) (Pure b) = eq a b+  liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs+  liftEq2 _ _ _ _ = False  instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where-  (==#) = (==##)+  liftEq = liftEq2 (==)+#else+instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where+  Pure a  `eq1` Pure b = a == b+  Free as `eq1` Free bs = as `eq1` bs+  _       `eq1` _ = False+#endif +#ifdef LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord2 (FreeF f) where-  Pure a `compare2` Pure b = a `compare` b-  Pure _ `compare2` Free _ = LT-  Free _ `compare2` Pure _ = GT-  Free fa `compare2` Free fb = fa `compare1` fb+  liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b+  liftCompare2 _ _ (Pure _) (Free _) = LT+  liftCompare2 _ _ (Free _) (Pure _) = GT+  liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb  instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where-  compare1 = compare2+  liftCompare = liftCompare2 compare+#else+instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where+  Pure a `compare1` Pure b = a `compare` b+  Pure _ `compare1` Free _ = LT+  Free _ `compare1` Pure _ = GT+  Free fa `compare1` Free fb = fa `compare1` fb+#endif  instance Functor f => Functor (FreeF f a) where   fmap _ (Pure a)  = Pure a@@ -179,31 +204,81 @@ free = FreeT . Identity {-# INLINE free #-} -deriving instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a)+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where+#else+instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where+#endif+    (==) = eq1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where+  liftEq eq = go+    where+      go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y+#else instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where-  (==#) = on (==#) (fmap (Lift1 . fmap Lift1) . runFreeT)+  eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)+#endif -deriving instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a)+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where+#else+instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where+#endif+    compare = compare1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where+  liftCompare cmp = go+    where+      go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y+#else instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where   compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)+#endif +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show1 m) => Show1 (FreeT f m) where+  liftShowsPrec sp sl = go+    where+      goList = liftShowList sp sl+      go d (FreeT x) = showsUnaryWith+        (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+        "FreeT" d x+#else instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where   showsPrec1 d (FreeT m) = showParen (d > 10) $     showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where+#else+instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where+#endif+  showsPrec = showsPrec1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read1 m) => Read1 (FreeT f m) where+  liftReadsPrec rp rl = go+    where+      goList = liftReadList rp rl+      go = readsData $ readsUnaryWith+        (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+        "FreeT" FreeT+#else instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where   readsPrec1 d =  readParen (d > 10) $ \r ->     [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]+#endif -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]+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where+#else+instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where+#endif+  readsPrec = readsPrec1  instance (Functor f, Monad m) => Functor (FreeT f m) where   fmap f (FreeT m) = FreeT (liftM f' m) where@@ -223,13 +298,17 @@   (>>-) = (>>=)  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)) +  fail = Fail.fail++instance (Functor f, Monad m) => Fail.MonadFail (FreeT f m) where+  fail e = FreeT (fail e)+ instance MonadTrans (FreeT f) where   lift = FreeT . liftM Pure   {-# INLINE lift #-}@@ -238,6 +317,10 @@   liftIO = lift . liftIO   {-# INLINE liftIO #-} +instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where+  liftBase = lift . liftBase+  {-# INLINE liftBase #-}+ instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where   ask = lift ask   {-# INLINE ask #-}@@ -331,6 +414,15 @@ -- @'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++-- | The very definition of a free monad transformer is that given a natural+-- transformation you get a monad transformer homomorphism.+foldFreeT :: (MonadTrans t, Monad (t m), Monad m)+          => (forall n x. Monad n => f x -> t n x) -> FreeT f m a -> t m a+foldFreeT f (FreeT m) = lift m >>= foldFreeF+  where+    foldFreeF (Pure a) = return a+    foldFreeF (Free as) = f as >>= foldFreeT f  -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@ transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b

@@ -0,0 +1,590 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Rank2Types #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#include "free-common.h"++--------------------------------------------------------------------------------+-- |+-- Given an applicative, the free monad transformer.+--------------------------------------------------------------------------------++module Control.Monad.Trans.Free.Ap+  (+  -- * The base functor+    FreeF(..)+  -- * The free monad transformer+  , FreeT(..)+  -- * The free monad+  , Free, free, runFree+  -- * Operations+  , liftF+  , iterT+  , iterTM+  , hoistFreeT+  , transFreeT+  , joinFreeT+  , cutoff+  , partialIterT+  , intersperseT+  , intercalateT+  , retractT+  -- * Operations of free monad+  , retract+  , iter+  , iterM+  -- * Free Monads With Class+  , MonadFree(..)+  ) where++import Control.Applicative+import Control.Monad (liftM, MonadPlus(..), join)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import Control.Monad.Trans.Class+import qualified Control.Monad.Fail as Fail+import Control.Monad.Free.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind hiding (join)+import Data.Functor.Classes.Compat+import Data.Monoid+import Data.Functor.Identity+import Data.Traversable+import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Data++#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+           )++#ifdef LIFTED_FUNCTOR_CLASSES+instance Show1 f => Show2 (FreeF f) where+  liftShowsPrec2 spa _sla _spb _slb d (Pure a) =+    showsUnaryWith spa "Pure" d a +  liftShowsPrec2 _spa _sla spb slb d (Free as) =+    showsUnaryWith (liftShowsPrec spb slb) "Free" d as++instance (Show1 f, Show a) => Show1 (FreeF f a) where+  liftShowsPrec = liftShowsPrec2 showsPrec showList+#else+instance (Show1 f, Show a) => Show1 (FreeF f a) where+  showsPrec1 d (Pure a)  = showParen (d > 10) $ showString "Pure " . showsPrec 11 a+  showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance Read1 f => Read2 (FreeF f) where+  liftReadsPrec2 rpa _rla rpb rlb = readsData $+    readsUnaryWith rpa "Pure" Pure `mappend`+    readsUnaryWith (liftReadsPrec rpb rlb) "Free" Free++instance (Read1 f, Read a) => Read1 (FreeF f a) where+  liftReadsPrec = liftReadsPrec2 readsPrec readList+#else+instance (Read1 f, Read a) => Read1 (FreeF f a) where+  readsPrec1 d r = readParen (d > 10)+      (\r' -> [ (Pure m, t)+             | ("Pure", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Free m, t)+             | ("Free", s) <- lex r'+             , (m, t) <- readsPrec1 11 s]) r+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance Eq1 f => Eq2 (FreeF f) where+  liftEq2 eq _ (Pure a) (Pure b) = eq a b+  liftEq2 _ eq (Free as) (Free bs) = liftEq eq as bs+  liftEq2 _ _ _ _ = False++instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where+  liftEq = liftEq2 (==)+#else+instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where+  Pure a  `eq1` Pure b = a == b+  Free as `eq1` Free bs = as `eq1` bs+  _       `eq1` _ = False+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance Ord1 f => Ord2 (FreeF f) where+  liftCompare2 cmp _ (Pure a) (Pure b) = cmp a b+  liftCompare2 _ _ (Pure _) (Free _) = LT+  liftCompare2 _ _ (Free _) (Pure _) = GT+  liftCompare2 _ cmp (Free fa) (Free fb) = liftCompare cmp fa fb++instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where+  liftCompare = liftCompare2 compare+#else+instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where+  Pure a `compare1` Pure b = a `compare` b+  Pure _ `compare1` Free _ = LT+  Free _ `compare1` Pure _ = GT+  Free fa `compare1` Free fb = fa `compare1` fb+#endif++instance Functor f => Functor (FreeF f a) where+  fmap _ (Pure a)  = Pure a+  fmap f (Free as) = Free (fmap f as)+  {-# INLINE fmap #-}++instance Foldable f => Foldable (FreeF f a) where+  foldMap f (Free as) = foldMap f as+  foldMap _ _         = mempty+  {-# INLINE foldMap #-}++instance Traversable f => Traversable (FreeF f a) where+  traverse _ (Pure a)  = pure (Pure a)+  traverse f (Free as) = Free <$> traverse f as+  {-# INLINE traverse #-}++instance Functor f => Bifunctor (FreeF f) where+  bimap f _ (Pure a)  = Pure (f a)+  bimap _ g (Free as) = Free (fmap g as)+  {-# INLINE bimap #-}++instance Foldable f => Bifoldable (FreeF f) where+  bifoldMap f _ (Pure a)  = f a+  bifoldMap _ g (Free as) = foldMap g as+  {-# INLINE bifoldMap #-}++instance Traversable f => Bitraversable (FreeF f) where+  bitraverse f _ (Pure a)  = Pure <$> f a+  bitraverse _ g (Free as) = Free <$> traverse g as+  {-# INLINE bitraverse #-}++transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b+transFreeF _ (Pure a) = Pure a+transFreeF t (Free as) = Free (t as)+{-# INLINE transFreeF #-}++-- | The \"free monad transformer\" for an applicative @f@+newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) }++-- | The \"free monad\" for an applicative @f@.+type Free f = FreeT f Identity++-- | Evaluates the first layer out of a free monad value.+runFree :: Free f a -> FreeF f a (Free f a)+runFree = runIdentity . runFreeT+{-# INLINE runFree #-}++-- | Pushes a layer into a free monad value.+free :: FreeF f a (Free f a) -> Free f a+free = FreeT . Identity+{-# INLINE free #-}++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where+#else+instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where+#endif+    (==) = eq1++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where+  liftEq eq = go+    where+      go (FreeT x) (FreeT y) = liftEq (liftEq2 eq go) x y+#else+instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where+  eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where+#else+instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where+#endif+    compare = compare1++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where+  liftCompare cmp = go+    where+      go (FreeT x) (FreeT y) = liftCompare (liftCompare2 cmp go) x y+#else+instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where+  compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show1 m) => Show1 (FreeT f m) where+  liftShowsPrec sp sl = go+    where+      goList = liftShowList sp sl+      go d (FreeT x) = showsUnaryWith+        (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+        "FreeT" d x+#else+instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where+  showsPrec1 d (FreeT m) = showParen (d > 10) $+    showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where+#else+instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where+#endif+  showsPrec = showsPrec1++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read1 m) => Read1 (FreeT f m) where+  liftReadsPrec rp rl = go+    where+      goList = liftReadList rp rl+      go = readsData $ readsUnaryWith+        (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+        "FreeT" FreeT+#else+instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where+  readsPrec1 d =  readParen (d > 10) $ \r ->+    [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]+#endif++#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where+#else+instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where+#endif+  readsPrec = readsPrec1++instance (Functor f, Monad m) => Functor (FreeT f m) where+  fmap f (FreeT m) = FreeT (liftM f' m) where+    f' (Pure a)  = Pure (f a)+    f' (Free as) = Free (fmap (fmap f) as)++instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where+  pure a = FreeT (return (Pure a))+  {-# INLINE pure #-}+  FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where+    g (Pure f') (Pure a') = Pure (f' a')+    g (Pure f') (Free as) = Free $ fmap f' <$> as+    g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs+    g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as+  {-# INLINE (<*>) #-}++instance (Apply f, Apply m, Monad m) => Apply (FreeT f m) where+  FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where+    g (Pure f') (Pure a') = Pure (f' a')+    g (Pure f') (Free as) = Free $ fmap f' <$> as+    g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs+    g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as++instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where+  FreeT m >>- f = FreeT $ m >>= \v -> case v of+    Pure a -> runFreeT (f a)+    Free w -> return (Free (fmap (>>- f) w))++instance (Applicative f, Applicative m, Monad m) => Monad (FreeT f m) where+  return = pure+  {-# INLINE return #-}+  FreeT m >>= f = FreeT $ m >>= \v -> case v of+    Pure a -> runFreeT (f a)+    Free w -> return (Free (fmap (>>= f) w))+  fail = Fail.fail++instance (Applicative f, Applicative m, Monad m) => Fail.MonadFail (FreeT f m) where+  fail e = FreeT (fail e)++instance MonadTrans (FreeT f) where+  lift = FreeT . liftM Pure+  {-# INLINE lift #-}++instance (Applicative f, Applicative m, MonadIO m) => MonadIO (FreeT f m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where+  ask = lift ask+  {-# INLINE ask #-}+  local f = hoistFreeT (local f)+  {-# INLINE local #-}++instance (Applicative f, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where+  tell = lift . tell+  {-# INLINE tell #-}+  listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)+    where+      concat' (Pure x, w) = Pure (x, w)+      concat' (Free y, w) = Free $ fmap (second (w <>)) <$> y+  pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m+    where+      clean = pass . liftM (\x -> (x, const mempty))+      pass' = join . liftM g+      g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)+      g (Free f)           = return . Free . fmap (FreeT . pass' . runFreeT) $ f+#if MIN_VERSION_mtl(2,1,1)+  writer w = lift (writer w)+  {-# INLINE writer #-}+#endif++instance (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where+  get = lift get+  {-# INLINE get #-}+  put = lift . put+  {-# INLINE put #-}+#if MIN_VERSION_mtl(2,1,1)+  state f = lift (state f)+  {-# INLINE state #-}+#endif++instance (Applicative f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}+  FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f)++instance (Applicative f, Applicative m, MonadCont m) => MonadCont (FreeT f m) where+  callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))++instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where+  empty = FreeT mzero+  FreeT ma <|> FreeT mb = FreeT (mplus ma mb)+  {-# INLINE (<|>) #-}++instance (Applicative f, Applicative m, MonadPlus m) => MonadPlus (FreeT f m) where+  mzero = FreeT mzero+  {-# INLINE mzero #-}+  mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)+  {-# INLINE mplus #-}++instance (Applicative f, Applicative m, Monad m) => MonadFree f (FreeT f m) where+  wrap = FreeT . return . Free+  {-# INLINE wrap #-}++instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance (Applicative f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where+  FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m+                                `Control.Monad.Catch.catch` (runFreeT . f)+  {-# INLINE catch #-}++-- | Given an applicative homomorphism from @f (m a)@ to @m a@,+-- tear down a free monad transformer using iteration.+iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a+iterT f (FreeT m) = do+    val <- m+    case fmap (iterT f) val of+        Pure x -> return x+        Free y -> f y++-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@,+-- tear down a free monad transformer using iteration over a transformer.+iterTM :: (Applicative f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a+iterTM f (FreeT m) = do+    val <- lift m+    case fmap (iterTM f) val of+        Pure x -> return x+        Free y -> f y++instance (Foldable m, Foldable f) => Foldable (FreeT f m) where+  foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m++instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where+  traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m++-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@+--+-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@+hoistFreeT :: (Monad m, Applicative 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 an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@+transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b+transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT++-- | Pull out and join @m@ layers of @'FreeT' f m a@.+joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)+joinFreeT (FreeT m) = m >>= joinFreeF+  where+    joinFreeF (Pure x) = return (return x)+    joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f++-- |+-- 'retract' is the left inverse of 'liftF'+--+-- @+-- 'retract' . 'liftF' = 'id'+-- @+retract :: Monad f => Free f a -> f a+retract m =+  case runIdentity (runFreeT m) of+    Pure a  -> return a+    Free as -> as >>= retract++-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.+iter :: Applicative f => (f a -> a) -> Free f a -> a+iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)++-- | Like 'iter' for monadic values.+iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a+iterM phi = iterT phi . hoistFreeT (return . runIdentity)++-- | Cuts off a tree of computations at a given depth.+-- If the depth is @0@ or less, no computation nor+-- monadic effects will take place.+--+-- Some examples (@n ≥ 0@):+--+-- @+-- 'cutoff' 0     _        ≡ 'return' 'Nothing'+-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just'+-- 'cutoff' (n+1) '.' 'lift'   ≡ 'lift' '.' 'liftM' 'Just'+-- 'cutoff' (n+1) '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('cutoff' n)+-- @+--+-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the+-- steps in the iteration is terminating.+cutoff :: (Applicative f, Applicative m, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)+cutoff n _ | n <= 0 = return Nothing+cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m++-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.+-- This is sort of the opposite for @'cutoff'@.+--+-- Some examples (@n ≥ 0@):+--+-- @+-- 'partialIterT' 0 _ m              ≡ m+-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return'+-- 'partialIterT' (n+1) phi '.' 'lift'   ≡ 'lift'+-- 'partialIterT' (n+1) phi '.' 'wrap'   ≡ 'join' . 'lift' . phi+-- @+partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b+partialIterT n phi m+  | n <= 0 = m+  | otherwise = FreeT $ do+      val <- runFreeT m+      case val of+        Pure a -> return (Pure a)+        Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi++-- | @intersperseT f m@ inserts a layer @f@ between every two layers in+-- @m@.+--+-- @+-- 'intersperseT' f '.' 'return' ≡ 'return'+-- 'intersperseT' f '.' 'lift'   ≡ 'lift'+-- 'intersperseT' f '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))+-- @+intersperseT :: (Monad m, Applicative m, Applicative f) => f a -> FreeT f m b -> FreeT f m b+intersperseT f (FreeT m) = FreeT $ do+  val <- m+  case val of+    Pure x -> return $ Pure x+    Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y++-- | Tear down a free monad transformer using Monad instance for @t m@.+retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a+retractT (FreeT m) = do+  val <- lift m+  case val of+    Pure x -> return x+    Free y -> y >>= retractT++-- | @intercalateT f m@ inserts a layer @f@ between every two layers in+-- @m@ and then retracts the result.+--+-- @+-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f+-- @+#if __GLASGOW_HASKELL__ < 710+intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b+#else+intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b+#endif+intercalateT f (FreeT m) = do+  val <- lift m+  case val of+    Pure x -> return x+    Free y -> y >>= iterTM (\x -> f >> join x)++#if __GLASGOW_HASKELL__ < 707+instance Typeable1 f => Typeable2 (FreeF f) where+  typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where+    f :: FreeF f a b -> f a+    f = undefined++instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where+  typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where+    f :: FreeT f w a -> f a+    f = undefined+    w :: FreeT f w a -> w a+    w = undefined++freeFTyCon, freeTTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT"+freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF"+#else+freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT"+freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF"+#endif+{-# NOINLINE freeTTyCon #-}+{-# NOINLINE freeFTyCon #-}++instance+  ( Typeable1 f, Typeable a, Typeable b+  , Data a, Data (f b), Data b+  ) => Data (FreeF f a b) where+    gfoldl f z (Pure a) = z Pure `f` a+    gfoldl f z (Free as) = z Free `f` as+    toConstr Pure{} = pureConstr+    toConstr Free{} = freeConstr+    gunfold k z c = case constrIndex c of+        1 -> k (z Pure)+        2 -> k (z Free)+        _ -> error "gunfold"+    dataTypeOf _ = freeFDataType+    dataCast1 f = gcast1 f++instance+  ( Typeable1 f, Typeable1 w, Typeable a+  , Data (w (FreeF f a (FreeT f w a)))+  , Data a+  ) => Data (FreeT f w a) where+    gfoldl f z (FreeT w) = z FreeT `f` w+    toConstr _ = freeTConstr+    gunfold k z c = case constrIndex c of+        1 -> k (z FreeT)+        _ -> error "gunfold"+    dataTypeOf _ = freeTDataType+    dataCast1 f = gcast1 f++pureConstr, freeConstr, freeTConstr :: Constr+pureConstr = mkConstr freeFDataType "Pure" [] Prefix+freeConstr = mkConstr freeFDataType "Free" [] Prefix+freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix+{-# NOINLINE pureConstr #-}+{-# NOINLINE freeConstr #-}+{-# NOINLINE freeTConstr #-}++freeFDataType, freeTDataType :: DataType+freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr]+freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr]+{-# NOINLINE freeFDataType #-}+{-# NOINLINE freeTDataType #-}+#endif

@@ -3,14 +3,7 @@ {-# 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+#include "free-common.h"  ----------------------------------------------------------------------------- -- |@@ -70,7 +63,7 @@ import qualified Data.Foldable as F import qualified Data.Traversable as T import Data.Functor.Bind hiding (join)-import Data.Function+import Data.Functor.Classes.Compat  #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable (Foldable)@@ -80,11 +73,25 @@ -- | 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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where+  liftEq eq x y = liftEq eq (fromFT x) (fromFT y) -instance (Functor f, Monad m, Ord (FreeT f m a)) => Ord (FT f m a) where-  compare = compare `on` fromFT+instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where+  liftCompare cmp x y= liftCompare cmp (fromFT x) (fromFT y)+#else+instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where+  eq1 x y = eq1 (fromFT x) (fromFT y)++instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where+  compare1 x y = compare1 (fromFT x) (fromFT y)+#endif++instance (Eq1 (FT f m), Eq a) => Eq (FT f m a) where+  (==) = eq1++instance (Ord1 (FT f m), Ord a) => Ord (FT f m a) where+  compare = compare1  instance Functor (FT f m) where   fmap f (FT k) = FT $ \a fr -> k (a . f) fr

@@ -1,18 +1,10 @@ {-# 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+#include "free-common.h"  ----------------------------------------------------------------------------- -- |@@ -81,6 +73,7 @@ import Control.Monad (ap, liftM, MonadPlus(..), join) import Control.Monad.Fix import Control.Monad.Trans.Class+import qualified Control.Monad.Fail as Fail import Control.Monad.Free.Class import Control.Monad.State.Class import Control.Monad.Error.Class@@ -92,14 +85,13 @@ import Data.Bitraversable import Data.Either import Data.Functor.Bind hiding (join)+import Data.Functor.Classes.Compat import Data.Functor.Identity-import Data.Function (on)-import Data.Monoid+import Data.Semigroup 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)@@ -133,33 +125,81 @@ runIter = runIdentity . runIterT {-# INLINE runIter #-} +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 m) => Eq1 (IterT m) where+  liftEq eq = go+    where+      go (IterT x) (IterT y) = liftEq (liftEq2 eq go) x y+#else instance (Functor m, Eq1 m) => Eq1 (IterT m) where-  (==#) = on (==#) (fmap (fmap Lift1) . runIterT)+  eq1 = on eq1 (fmap (fmap Lift1) . runIterT)+#endif -instance Eq (m (Either a (IterT m a))) => Eq (IterT m a) where-  IterT m == IterT n = m == n+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Eq1 m, Eq a) => Eq (IterT m a) where+#else+instance (Functor m, Eq1 m, Eq a) => Eq (IterT m a) where+#endif+  (==) = eq1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 m) => Ord1 (IterT m) where+  liftCompare cmp = go+    where+      go (IterT x) (IterT y) = liftCompare (liftCompare2 cmp go) x y+#else instance (Functor m, Ord1 m) => Ord1 (IterT m) where   compare1 = on compare1 (fmap (fmap Lift1) . runIterT)+#endif -instance Ord (m (Either a (IterT m a))) => Ord (IterT m a) where-  compare (IterT m) (IterT n) = compare m n+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Ord1 m, Ord a) => Ord (IterT m a) where+#else+instance (Functor m, Ord1 m, Ord a) => Ord (IterT m a) where+#endif+  compare = compare1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 m) => Show1 (IterT m) where+  liftShowsPrec sp sl = go+    where+      goList = liftShowList sp sl+      go d (IterT x) = showsUnaryWith+        (liftShowsPrec (liftShowsPrec2 sp sl go goList) (liftShowList2 sp sl go goList))+        "IterT" d x     +#else instance (Functor m, Show1 m) => Show1 (IterT m) where   showsPrec1 d (IterT m) = showParen (d > 10) $     showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m)+#endif -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+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Show1 m, Show a) => Show (IterT m a) where+#else+instance (Functor m, Show1 m, Show a) => Show (IterT m a) where+#endif+  showsPrec = showsPrec1 +#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 m) => Read1 (IterT m) where+  liftReadsPrec rp rl = go+    where+      goList = liftReadList rp rl+      go = readsData $ readsUnaryWith+        (liftReadsPrec (liftReadsPrec2 rp rl go goList) (liftReadList2 rp rl go goList))+        "IterT" IterT+#else instance (Functor m, Read1 m) => Read1 (IterT m) where   readsPrec1 d =  readParen (d > 10) $ \r ->     [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+#endif -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]+#ifdef LIFTED_FUNCTOR_CLASSES+instance (Read1 m, Read a) => Read (IterT m a) where+#else+instance (Functor m, Read1 m, Read a) => Read (IterT m a) where+#endif+  readsPrec = readsPrec1  instance Monad m => Functor (IterT m) where   fmap f = IterT . liftM (bimap f (fmap f)) . runIterT@@ -176,6 +216,10 @@   {-# INLINE return #-}   IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k))   {-# INLINE (>>=) #-}+  fail = Fail.fail+  {-# INLINE fail #-}++instance Monad m => Fail.MonadFail (IterT m) where   fail _ = never   {-# INLINE fail #-} @@ -240,7 +284,7 @@   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+      concat' (Right y, w) = Right $ second (w `mappend`) <$> y   pass m = IterT . pass' . runIterT . hoistIterT clean $ listen m     where       clean = pass . liftM (\x -> (x, const mempty))@@ -388,17 +432,9 @@ interleave_ xs = IterT $ liftM (Right . interleave_ . rights) $ mapM runIterT xs {-# INLINE interleave_ #-} -instance (Monad m, Monoid a) => Monoid (IterT m a) where+instance (Monad m, Semigroup a, 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-+  mappend = (<>)   mconcat = mconcat' . map Right     where       mconcat' :: (Monad m, Monoid a) => [Either a (IterT m a)] -> IterT m a@@ -416,7 +452,17 @@        compact' a []               = [Left a]       compact' a (r@(Right _):xs) = (Left a):(r:(compact xs))-      compact' a (  (Left a'):xs) = compact' (a <> a') xs+      compact' a (  (Left a'):xs) = compact' (a `mappend` a') xs++instance (Monad m, Semigroup a) => Semigroup (IterT m a) where+  x <> y = IterT $ do+    x' <- runIterT x+    y' <- runIterT y+    case (x', y') of+      ( Left a, Left b)  -> return . Left  $ a <> b+      ( Left a, Right b) -> return . Right $ liftM (a <>) b+      (Right a, Left b)  -> return . Right $ liftM (<> b) a+      (Right a, Right b) -> return . Right $ a <> b  #if __GLASGOW_HASKELL__ < 707 instance Typeable1 m => Typeable1 (IterT m) where

@@ -0,0 +1,43 @@+#include "free-common.h"+#ifdef LIFTED_FUNCTOR_CLASSES+module Data.Functor.Classes.Compat (+    mappend,+    module Data.Functor.Classes,+    ) where++import Data.Functor.Classes++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (mappend)+#endif+#else+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Functor.Classes.Compat (+    Lift1 (..),+    on,+    module Data.Functor.Classes,+    ) where++-------------------------------------------------------------------------------+-- transformers-0.4 helpers, copied from prelude-extras+-------------------------------------------------------------------------------++# if !(MIN_VERSION_base(4,8,0))+import Data.Foldable+import Data.Traversable+# endif+import Data.Functor.Classes+import Data.Function (on)++-- If Show1 and Read1 are ever derived by the same mechanism as+-- Show and Read, rather than GND, that will change their behavior+-- here.+newtype Lift1 f a = Lift1 { lower1 :: f a }+  deriving (Functor, Foldable, Traversable, Eq1, Ord1, Show1, Read1)++instance (Eq1 f, Eq a) => Eq (Lift1 f a)       where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Lift1 f a)    where compare = compare1+instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec = showsPrec1+instance (Read1 f, Read a) => Read (Lift1 f a) where readsPrec = readsPrec1+#endif