diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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.* diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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. diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 --- /dev/null +++ b/examples/LICENSE @@ -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. diff --git a/examples/PerfTH.hs b/examples/PerfTH.hs new file mode 100644 --- /dev/null +++ b/examples/PerfTH.hs @@ -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" + diff --git a/examples/RetryTH.hs b/examples/RetryTH.hs --- a/examples/RetryTH.hs +++ b/examples/RetryTH.hs @@ -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 diff --git a/examples/Teletype.lhs b/examples/Teletype.lhs --- a/examples/Teletype.lhs +++ b/examples/Teletype.lhs @@ -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 diff --git a/examples/ValidationForm.hs b/examples/ValidationForm.hs --- a/examples/ValidationForm.hs +++ b/examples/ValidationForm.hs @@ -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 diff --git a/examples/free-examples.cabal b/examples/free-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/free-examples.cabal @@ -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 +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 diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -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 @@ -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.* diff --git a/include/free-common.h b/include/free-common.h new file mode 100644 --- /dev/null +++ b/include/free-common.h @@ -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 diff --git a/src/Control/Alternative/Free.hs b/src/Control/Alternative/Free.hs --- a/src/Control/Alternative/Free.hs +++ b/src/Control/Alternative/Free.hs @@ -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 #-} diff --git a/src/Control/Alternative/Free/Final.hs b/src/Control/Alternative/Free/Final.hs --- a/src/Control/Alternative/Free/Final.hs +++ b/src/Control/Alternative/Free/Final.hs @@ -1,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 diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -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 diff --git a/src/Control/Applicative/Free/Fast.hs b/src/Control/Applicative/Free/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Free/Fast.hs @@ -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 . +-------------------------------------------------------------------------------- +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 diff --git a/src/Control/Applicative/Free/Final.hs b/src/Control/Applicative/Free/Final.hs --- a/src/Control/Applicative/Free/Final.hs +++ b/src/Control/Applicative/Free/Final.hs @@ -1,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 diff --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs --- a/src/Control/Applicative/Trans/Free.hs +++ b/src/Control/Applicative/Trans/Free.hs @@ -5,6 +5,8 @@ {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -Wall #-} +#include "free-common.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative.Trans.Free diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs --- a/src/Control/Comonad/Cofree.hs +++ b/src/Control/Comonad/Cofree.hs @@ -1,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 . --- For a practical application, check --- by Neil Ghani et al. +-- For a practical application, check +-- by Neil Ghani et al. data Cofree f a = a :< f (Cofree f a) #if __GLASGOW_HASKELL__ >= 707 deriving (Typeable) + +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 #-} diff --git a/src/Control/Comonad/Cofree/Class.hs b/src/Control/Comonad/Cofree/Class.hs --- a/src/Control/Comonad/Cofree/Class.hs +++ b/src/Control/Comonad/Cofree/Class.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +#include "free-common.h" ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Cofree.Class diff --git a/src/Control/Comonad/Trans/Cofree.hs b/src/Control/Comonad/Trans/Cofree.hs --- a/src/Control/Comonad/Trans/Cofree.hs +++ b/src/Control/Comonad/Trans/Cofree.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Control/Comonad/Trans/Coiter.hs b/src/Control/Comonad/Trans/Coiter.hs --- a/src/Control/Comonad/Trans/Coiter.hs +++ b/src/Control/Comonad/Trans/Coiter.hs @@ -1,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. diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs --- a/src/Control/Monad/Free.hs +++ b/src/Control/Monad/Free.hs @@ -1,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 diff --git a/src/Control/Monad/Free/Ap.hs b/src/Control/Monad/Free/Ap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Free/Ap.hs @@ -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 +-- +-- * +-- +-- * +-------------------------------------------------------------------------------- +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 diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -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) diff --git a/src/Control/Monad/Free/Class.hs b/src/Control/Monad/Free/Class.hs --- a/src/Control/Monad/Free/Class.hs +++ b/src/Control/Monad/Free/Class.hs @@ -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 diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs --- a/src/Control/Monad/Free/TH.hs +++ b/src/Control/Monad/Free/TH.hs @@ -1,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@. diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -1,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 diff --git a/src/Control/Monad/Trans/Free/Ap.hs b/src/Control/Monad/Trans/Free/Ap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Free/Ap.hs @@ -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 diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs --- a/src/Control/Monad/Trans/Free/Church.hs +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -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 diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs --- a/src/Control/Monad/Trans/Iter.hs +++ b/src/Control/Monad/Trans/Iter.hs @@ -1,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 diff --git a/src/Data/Functor/Classes/Compat.hs b/src/Data/Functor/Classes/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Classes/Compat.hs @@ -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