recursion-schemes 5.1.3 → 5.2
raw patch · 7 files changed
+584/−376 lines, 7 filesdep +containersdep +data-fixdep ~th-abstraction
Dependencies added: containers, data-fix
Dependency ranges changed: th-abstraction
Files
- .travis.yml +114/−99
- CHANGELOG.markdown +9/−0
- README.markdown +1/−1
- recursion-schemes.cabal +11/−6
- src/Data/Functor/Base.hs +176/−1
- src/Data/Functor/Foldable.hs +134/−233
- src/Data/Functor/Foldable/TH.hs +139/−36
.travis.yml view
@@ -2,29 +2,33 @@ # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' #+# To regenerate the script (for example after adjusting tested-with) run+#+# haskell-ci regenerate+# # For more information, see https://github.com/haskell-CI/haskell-ci #-# version: 0.2.1+# version: 0.10.2 #+version: ~> 1.0 language: c+os: linux dist: xenial- git:- submodules: false # whether to recursively clone submodules-+ # whether to recursively clone submodules+ submodules: false notifications: irc: channels:- - "irc.freenode.org#haskell-lens"+ - irc.freenode.org#haskell-lens skip_join: true template: - "\x0313recursion-schemes\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"- cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store-+ - $HOME/.hlint before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update'@@ -33,120 +37,131 @@ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx- - rm -rfv $CABALHOME/packages/head.hackage--matrix:+jobs: include:- - compiler: "ghc-8.6.4"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.4"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.2"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.2"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.10.3"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.8.4"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}}- - compiler: "ghc-7.6.3"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.4.2"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.4.2], 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:- - compiler: "ghc-head"-+ - compiler: ghc-8.10.1+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-8.8.3+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-8.6.5+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-8.4.4+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-8.2.2+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-8.0.2+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-7.10.3+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-7.8.4+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-7.6.3+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.2"]}}+ os: linux+ - compiler: ghc-7.4.2+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.2"]}}+ os: linux before_install:- - HC=/opt/ghc/bin/${CC}- - HCPKG=${HC/ghc/ghc-pkg}+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')+ - WITHCOMPILER="-w $HC"+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')+ - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH"- - ROOTDIR=$(pwd)- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+ - TOP=$(pwd)+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER-+ - CABAL="$CABAL -vnormal+nowrap"+ - set -o pipefail+ - TEST=--enable-tests+ - BENCH=--enable-benchmarks+ - HEADHACKAGE=false+ - rm -f $CABALHOME/config+ - |+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config+ echo "write-ghc-environment-files: always" >> $CABALHOME/config+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config+ echo "install-dirs user" >> $CABALHOME/config+ echo " prefix: $CABALHOME" >> $CABALHOME/config+ echo "repository hackage.haskell.org" >> $CABALHOME/config+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - TEST=--enable-tests- - BENCH=--enable-benchmarks- - GHCHEAD=${GHCHEAD-false}- - travis_retry ${CABAL} update -v- - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/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 's/-- allow-newer: .*/allow-newer: *:base/' $CABALHOME/config- for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" $CABALHOME/config; done-- echo 'repository head.hackage' >> $CABALHOME/config- echo ' url: http://head.hackage.haskell.org/' >> $CABALHOME/config- echo ' secure: True' >> $CABALHOME/config- echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> $CABALHOME/config- echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> $CABALHOME/config- echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> $CABALHOME/config- echo ' key-threshold: 3' >> $CABALHOME.config-- grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'-- ${CABAL} new-update head.hackage -v- fi- - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'- - if [ $HCNUMVER -ge 80000 ] ; then ${CABAL} new-install -w ${HC} -j2 doctest --constraint='doctest ==0.16.*' ; fi- - rm -f cabal.project+ echo "program-default-options" >> $CABALHOME/config+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config+ - cat $CABALHOME/config+ - rm -fv cabal.project cabal.project.local cabal.project.freeze+ - travis_retry ${CABAL} v2-update -v+ - if [ $HCNUMVER -ge 80000 ] ; then ${CABAL} v2-install $WITHCOMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.17' ; fi+ # Generate cabal.project+ - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project- - "printf 'packages: \".\"\\n' >> cabal.project"- - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"- - touch cabal.project.local- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(recursion-schemes)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"+ - |+ echo "packages: ." >> cabal.project+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package recursion-schemes' >> cabal.project ; fi+ - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"+ - |+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(recursion-schemes)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi- - rm -f cabal.project.freeze- - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry- - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"- - rm "cabal.project.freeze"- - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all- - rm -rf .ghc.environment.* "."/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.+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"+ - rm cabal.project.freeze+ - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all script:- # test that source-distributions can be generated- - ${CABAL} new-sdist all+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)+ # Packaging...+ - ${CABAL} v2-sdist all+ # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false- - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;- - rm -f cabal.project+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;+ - PKGDIR_recursion_schemes="$(find . -maxdepth 1 -type d -regex '.*/recursion-schemes-[0-9.]*')"+ # Generate cabal.project+ - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project- - "printf 'packages: \"recursion-schemes-*/*.cabal\"\\n' >> cabal.project"- - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"- - touch cabal.project.local- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(recursion-schemes)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"+ - |+ echo "packages: ${PKGDIR_recursion_schemes}" >> cabal.project+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package recursion-schemes' >> cabal.project ; fi+ - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"+ - |+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(recursion-schemes)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true-+ # Building with tests and benchmarks... # build & run tests, build benchmarks- - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all- - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi-- # doctest- - if [ $HCNUMVER -ge 80000 ] ; then (cd recursion-schemes-* && doctest -DCURRENT_PACKAGE_KEY='"recursion-schemes"' src) ; fi-- # cabal check- - (cd recursion-schemes-* && ${CABAL} check)-- # haddock- - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all+ # Testing...+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all+ # Doctest...+ - if [ $HCNUMVER -ge 80000 ] ; then (cd ${PKGDIR_recursion_schemes} && doctest -DCURRENT_PACKAGE_KEY='"recursion-schemes"' -this-unit-id recursion-schemes src) ; fi+ # cabal check...+ - (cd ${PKGDIR_recursion_schemes} && ${CABAL} -vnormal check)+ # haddock...+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all -# REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]+# REGENDATA ("0.10.2",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) # EOF
CHANGELOG.markdown view
@@ -1,3 +1,12 @@+## 5.2++* Add instances for `Tree` (from `containers`)+* Add some haddocks and basic examples+* Generalize the type of `makeBaseFunctor(With)`, such that+ it can take also `Dec`. This way you may supply context for `Recursive`+ and `Corecursive` instances.+* Depend on `data-fix` package for fixed point types.+ ## 5.1.3 [2019.04.26] * Support `th-abstraction-0.3.0.0` or later.
README.markdown view
@@ -14,7 +14,7 @@ This library lists the most common recursion schemes, and also provides an implementation corresponding to each one. The idea is that a recursive function may be broken into two parts: the part which is the same in all the recursive functions which follow a given recursion scheme, and the part which is different in each function. Our implementation performs the recursive, common part, and takes as input a function which performs the non-recursive, unique part. -If you use those implementations instead of making explicit recursive calls, your code will simultaneously become clearer (to those who are familiar with recursion schemes) and more obscure (to those who aren't). Obviously, if one knows how to read and understand recursive code but does not know what e.g. `para` means, then the version which uses `para` will look needlessly obfuscated compared to the version they already know how to read. But if one is familiar with `para`, then seeing this familiar name will instantly clarify that this is a spine-based function, like `Map.insert`, which allocates new nodes along a spine but leaves the rest of the nodes untouched. This is a very useful starting point, guiding the reader to look for the logic which decides which sub-trees to drill through and which sub-trees to leave untouched. In contrast, with the general-recursion version, the reader has no such starting point and must thus read through the entire function (or guess based on the function's name) before they can infer that kind of big picture information.+If you use those implementations instead of making explicit recursive calls, your code will simultaneously become clearer (to those who are familiar with recursion schemes) and more obscure (to those who aren't). Obviously, if one knows how to read and understand recursive code but does not know what e.g. `para` means, then the version which uses `para` will look needlessly obfuscated compared to the version they already know how to read. But if one is familiar with `para`, then seeing this familiar name will instantly clarify that this is a path-copying function in the style of `Map.insert`, which allocates new nodes along a path from a node to the root but leaves the rest of the nodes untouched. This is a very useful starting point, guiding the reader to look for the logic which decides which sub-trees to drill through and which sub-trees to leave untouched. In contrast, with the general-recursion version, the reader has no such starting point and must thus read through the entire function (or guess based on the function's name) before they can infer that kind of big picture information. ### Faster
recursion-schemes.cabal view
@@ -1,8 +1,8 @@ name: recursion-schemes category: Control, Recursion-version: 5.1.3+version: 5.2 license: BSD2-cabal-version: >= 1.8+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: "Samuel Gélineau" <gelisam@gmail.com>,@@ -15,7 +15,7 @@ synopsis: Representing common recursion patterns as higher-order functions description: Many recursive functions share the same structure, e.g. pattern-match on the input and, depending on the data constructor, either recur on a smaller input or terminate the recursion with the base case. Another one: start with a seed value, use it to produce the first element of an infinite list, and recur on a modified seed in order to produce the rest of the list. Such a structure is called a recursion scheme. Using higher-order functions to implement those recursion schemes makes your code clearer, faster, and safer. See README for details. -tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.4+tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 build-type: Simple extra-source-files: .travis.yml CHANGELOG.markdown .gitignore README.markdown include/recursion-schemes-common.h@@ -46,7 +46,9 @@ build-depends: base >= 4.5 && < 5,+ containers >= 0.4.2.1 && < 0.7, comonad >= 4 && < 6,+ data-fix >= 0.3.0 && < 0.4, free >= 4 && < 6, transformers >= 0.3.0.0 && < 1 @@ -73,15 +75,16 @@ nats, transformers-compat >= 0.3 && < 1 + -- Foldable module is first, so cabal repl loads it! exposed-modules:- Data.Functor.Base Data.Functor.Foldable+ Data.Functor.Base if flag(template-haskell) build-depends:- template-haskell >= 2.5.0.0 && < 2.15,+ template-haskell >= 2.5.0.0 && < 2.17, base-orphans >= 0.5.4 && < 0.9,- th-abstraction >= 0.2.4 && < 0.4+ th-abstraction >= 0.3 && < 0.4 exposed-modules: Data.Functor.Foldable.TH @@ -89,12 +92,14 @@ Paths_recursion_schemes ghc-options: -Wall+ default-language: Haskell2010 test-suite Expr type: exitcode-stdio-1.0 main-is: Expr.hs hs-source-dirs: examples ghc-options: -Wall -threaded+ default-language: Haskell2010 build-depends: base, HUnit <1.7,
src/Data/Functor/Base.hs view
@@ -10,7 +10,9 @@ -- | Base Functors for standard types not already expressed as a fixed point. module Data.Functor.Base- ( NonEmptyF(..)+ ( ListF (..)+ , NonEmptyF(..)+ , TreeF (..), ForestF, ) where #ifdef __GLASGOW_HASKELL__@@ -42,6 +44,101 @@ import Prelude hiding (head, tail) +-------------------------------------------------------------------------------+-- ListF+-------------------------------------------------------------------------------++-- | Base functor of @[]@.+data ListF a b = Nil | Cons a b+ deriving (Eq,Ord,Show,Read,Typeable+#if HAS_GENERIC+ , Generic+#endif+#if HAS_GENERIC1+ , Generic1+#endif+ )++#ifdef LIFTED_FUNCTOR_CLASSES+instance Eq2 ListF where+ liftEq2 _ _ Nil Nil = True+ liftEq2 f g (Cons a b) (Cons a' b') = f a a' && g b b'+ liftEq2 _ _ _ _ = False++instance Eq a => Eq1 (ListF a) where+ liftEq = liftEq2 (==)++instance Ord2 ListF where+ liftCompare2 _ _ Nil Nil = EQ+ liftCompare2 _ _ Nil _ = LT+ liftCompare2 _ _ _ Nil = GT+ liftCompare2 f g (Cons a b) (Cons a' b') = f a a' `mappend` g b b'++instance Ord a => Ord1 (ListF a) where+ liftCompare = liftCompare2 compare++instance Show a => Show1 (ListF a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 ListF where+ liftShowsPrec2 _ _ _ _ _ Nil = showString "Nil"+ liftShowsPrec2 sa _ sb _ d (Cons a b) = showParen (d > 10)+ $ showString "Cons "+ . sa 11 a+ . showString " "+ . sb 11 b++instance Read2 ListF where+ liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> nil s ++ cons s+ where+ nil s0 = do+ ("Nil", s1) <- lex s0+ return (Nil, s1)+ cons s0 = do+ ("Cons", s1) <- lex s0+ (a, s2) <- ra 11 s1+ (b, s3) <- rb 11 s2+ return (Cons a b, s3)++instance Read a => Read1 (ListF a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++#else+instance Eq a => Eq1 (ListF a) where eq1 = (==)+instance Ord a => Ord1 (ListF a) where compare1 = compare+instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec+instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec+#endif++-- These instances cannot be auto-derived on with GHC <= 7.6+instance Functor (ListF a) where+ fmap _ Nil = Nil+ fmap f (Cons a b) = Cons a (f b)++instance F.Foldable (ListF a) where+ foldMap _ Nil = Data.Monoid.mempty+ foldMap f (Cons _ b) = f b++instance T.Traversable (ListF a) where+ traverse _ Nil = pure Nil+ traverse f (Cons a b) = Cons a <$> f b++instance Bi.Bifunctor ListF where+ bimap _ _ Nil = Nil+ bimap f g (Cons a b) = Cons (f a) (g b)++instance Bi.Bifoldable ListF where+ bifoldMap _ _ Nil = mempty+ bifoldMap f g (Cons a b) = mappend (f a) (g b)++instance Bi.Bitraversable ListF where+ bitraverse _ _ Nil = pure Nil+ bitraverse f g (Cons a b) = Cons <$> f a <*> g b++-------------------------------------------------------------------------------+-- NonEmpty+-------------------------------------------------------------------------------+ -- | Base Functor for 'Data.List.NonEmpty' data NonEmptyF a b = NonEmptyF { head :: a, tail :: Maybe b } deriving (Eq,Ord,Show,Read,Typeable@@ -114,3 +211,81 @@ instance Bi.Bitraversable NonEmptyF where bitraverse f g = liftA2 NonEmptyF <$> (f . head) <*> (T.traverse g . tail)++-------------------------------------------------------------------------------+-- Tree+-------------------------------------------------------------------------------++-- | Base functor for 'Data.Tree.Tree'.+data TreeF a b = NodeF a (ForestF a b)+ deriving (Eq,Ord,Show,Read,Typeable+#if HAS_GENERIC+ , Generic+#endif+#if HAS_GENERIC1+ , Generic1+#endif+ )++type ForestF a b = [b]++#ifdef LIFTED_FUNCTOR_CLASSES+instance Eq2 TreeF where+ liftEq2 f g (NodeF a mb) (NodeF a' mb') = f a a' && liftEq g mb mb'++instance Eq a => Eq1 (TreeF a) where+ liftEq = liftEq2 (==)++instance Ord2 TreeF where+ liftCompare2 f g (NodeF a mb) (NodeF a' mb') = f a a' `mappend` liftCompare g mb mb'++instance Ord a => Ord1 (TreeF a) where+ liftCompare = liftCompare2 compare++instance Show a => Show1 (TreeF a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 TreeF where+ liftShowsPrec2 sa _ sb slb d (NodeF a b) = showParen (d > 10)+ $ showString "NodeF "+ . sa 11 a+ . showString " "+ . liftShowsPrec sb slb 11 b++instance Read2 TreeF where+ liftReadsPrec2 ra _ rb rlb d = readParen (d > 10) $ \s -> cons s+ where+ cons s0 = do+ ("NodeF", s1) <- lex s0+ (a, s2) <- ra 11 s1+ (mb, s3) <- liftReadsPrec rb rlb 11 s2+ return (NodeF a mb, s3)++instance Read a => Read1 (TreeF a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++#else+instance Eq a => Eq1 (TreeF a) where eq1 = (==)+instance Ord a => Ord1 (TreeF a) where compare1 = compare+instance Show a => Show1 (TreeF a) where showsPrec1 = showsPrec+instance Read a => Read1 (TreeF a) where readsPrec1 = readsPrec+#endif++-- These instances cannot be auto-derived on with GHC <= 7.6+instance Functor (TreeF a) where+ fmap f (NodeF x xs) = NodeF x (fmap f xs)++instance F.Foldable (TreeF a) where+ foldMap f (NodeF _ xs) = F.foldMap f xs++instance T.Traversable (TreeF a) where+ traverse f (NodeF x xs) = NodeF x <$> T.traverse f xs++instance Bi.Bifunctor TreeF where+ bimap f g (NodeF x xs) = NodeF (f x) (fmap g xs)++instance Bi.Bifoldable TreeF where+ bifoldMap f g (NodeF x xs) = f x `mappend` F.foldMap g xs++instance Bi.Bitraversable TreeF where+ bitraverse f g (NodeF x xs) = liftA2 NodeF (f x) (T.traverse g xs)
src/Data/Functor/Foldable.hs view
@@ -29,10 +29,6 @@ -- * Base functors for fixed points Base , ListF(..)- -- * Fixed points- , Fix(..), unfix- , Mu(..), hoistMu- , Nu(..), hoistNu -- * Folding , Recursive(..) -- ** Combinators@@ -105,58 +101,91 @@ import qualified Control.Monad.Trans.Free as CMTF import Data.Functor.Identity import Control.Arrow-import Data.Function (on)-import Data.Functor.Classes import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty(NonEmpty((:|)), nonEmpty, toList)-import Text.Read-import Text.Show+import Data.Tree (Tree (..)) #ifdef __GLASGOW_HASKELL__-import Data.Data hiding (gunfold)-#if HAS_POLY_TYPEABLE-#else-import qualified Data.Data as Data-#endif #if HAS_GENERIC import GHC.Generics (Generic (..), M1 (..), V1, U1, K1 (..), (:+:) (..), (:*:) (..)) #endif-#if HAS_GENERIC1-import GHC.Generics (Generic1) #endif-#endif import Numeric.Natural-import Data.Monoid (Monoid (..)) import Prelude -import qualified Data.Foldable as F-import qualified Data.Traversable as T--import qualified Data.Bifunctor as Bi-import qualified Data.Bifoldable as Bi-import qualified Data.Bitraversable as Bi- import Data.Functor.Base hiding (head, tail) import qualified Data.Functor.Base as NEF (NonEmptyF(..)) +import Data.Fix (Fix (..), unFix, Mu (..), Nu (..))+ -- $setup--- >>> :set -XDeriveFunctor+-- >>> :set -XDeriveFunctor -XScopedTypeVariables -XLambdaCase -XGADTs -XFlexibleContexts -- >>> import Control.Monad (void) -- >>> import Data.Char (toUpper)+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (partition)+-- >>> import Data.Maybe (maybeToList)+--+-- >>> let showTree = putStrLn . go where go (Node x xs) = if null xs then x else "(" ++ unwords (x : map go xs) ++ ")" +-- | Obtain the base functor for a recursive datatype.+--+-- The core idea of this library is that instead of writing recursive functions+-- on a recursive datatype, we prefer to write non-recursive functions on a+-- related, non-recursive datatype we call the "base functor".+--+-- For example, @[a]@ is a recursive type, and its corresponding base functor is+-- @'ListF' a@:+--+-- @+-- data 'ListF' a b = 'Nil' | 'Cons' a b+-- type instance 'Base' [a] = 'ListF' a+-- @+--+-- The relationship between those two types is that if we replace @b@ with+-- @'ListF' a@, we obtain a type which is isomorphic to @[a]@.+-- type family Base t :: * -> * +-- | A recursive datatype which can be unrolled one recursion layer at a time.+--+-- For example, a value of type @[a]@ can be unrolled into a @'ListF' a [a]@.+-- Ifthat unrolled value is a 'Cons', it contains another @[a]@ which can be+-- unrolled as well, and so on.+--+-- Typically, 'Recursive' types also have a 'Corecursive' instance, in which+-- case 'project' and 'embed' are inverses. class Functor (Base t) => Recursive t where+ -- | Unroll a single recursion layer.+ --+ -- >>> project [1,2,3]+ -- Cons 1 [2,3] project :: t -> Base t t #ifdef HAS_GENERIC default project :: (Generic t, Generic (Base t t), GCoerce (Rep t) (Rep (Base t t))) => t -> Base t t project = to . gcoerce . from #endif + -- | A generalization of 'foldr'. The elements of the base functor, called the+ -- "recursive positions", give the result of folding the sub-tree at that+ -- position.+ --+ -- >>> :{+ -- >>> let oursum = cata $ \case+ -- >>> Nil -> 0+ -- >>> Cons x acc -> x + acc+ -- >>> :}+ --+ -- >>> oursum [1,2,3]+ -- 6+ -- cata :: (Base t a -> a) -- ^ a (Base t)-algebra -> t -- ^ fixed point -> a -- ^ result cata f = c where c = f . fmap c . project + -- | A variant of 'cata' in which recursive positions also include the+ -- original sub-tree, in addition to the result of folding that sub-tree.+ -- para :: (Base t (t, a) -> a) -> t -> a para t = p where p x = t . fmap ((,) <*> p) $ project x @@ -188,13 +217,39 @@ distParaT :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> Base t (EnvT t w a) -> EnvT t w (Base t a) distParaT t = distZygoT embed t +-- | A recursive datatype which can be rolled up one recursion layer at a time.+--+-- For example, a value of type @'ListF' a [a]@ can be rolled up into a @[a]@.+-- This @[a]@ can then be used in a 'Cons' to construct another @'ListF' a [a]@,+-- which can be rolled up as well, and so on.+--+-- Typically, 'Corecursive' types also have a 'Recursive' instance, in which+-- case 'embed' and 'project' are inverses. class Functor (Base t) => Corecursive t where++ -- | Roll up a single recursion layer.+ --+ -- >>> embed (Cons 1 [2,3])+ -- [1,2,3] embed :: Base t t -> t #ifdef HAS_GENERIC default embed :: (Generic t, Generic (Base t t), GCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t embed = to . gcoerce . from #endif + -- | A generalization of 'unfoldr'. The starting seed is expanded into a base+ -- functor whose recursive positions contain more seeds, which are themselves+ -- expanded, and so on.+ --+ -- >>> :{+ -- >>> let ourEnumFromTo :: Int -> Int -> [Int]+ -- >>> ourEnumFromTo lo hi = ana go lo where+ -- >>> go i = if i > hi then Nil else Cons i (i + 1)+ -- >>> :}+ --+ -- >>> ourEnumFromTo 1 4+ -- [1,2,3,4]+ -- ana :: (a -> Base t a) -- ^ a (Base t)-coalgebra -> a -- ^ seed@@ -223,105 +278,43 @@ -> t gpostpro k e g = a . return where a = embed . fmap (hoist e . a . join) . k . liftM g +-- | An optimized version of @cata f . ana g@.+--+-- Useful when your recursion structure is shaped like a particular recursive+-- datatype, but you're neither consuming nor producing that recursive datatype.+-- For example, the recursion structure of quick sort is a binary tree, but its+-- input and output is a list, not a binary tree.+--+-- >>> data BinTreeF a b = Tip | Branch b a b deriving (Functor)+--+-- >>> :{+-- >>> let quicksort :: Ord a => [a] -> [a]+-- >>> quicksort = hylo merge split where+-- >>> split [] = Tip+-- >>> split (x:xs) = let (l, r) = partition (<x) xs in Branch l x r+-- >>>+-- >>> merge Tip = []+-- >>> merge (Branch l x r) = l ++ [x] ++ r+-- >>> :}+--+-- >>> quicksort [1,5,2,8,4,9,8]+-- [1,2,4,5,8,8,9]+-- hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b hylo f g = h where h = f . fmap h . g +-- | An alias for 'cata'. fold :: Recursive t => (Base t a -> a) -> t -> a fold = cata +-- | An alias for 'ana'. unfold :: Corecursive t => (a -> Base t a) -> a -> t unfold = ana +-- | An alias for 'hylo'. refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b refold = hylo --- | Base functor of @[]@.-data ListF a b = Nil | Cons a b- deriving (Eq,Ord,Show,Read,Typeable-#if HAS_GENERIC- , Generic-#endif-#if HAS_GENERIC1- , Generic1-#endif- )--#ifdef LIFTED_FUNCTOR_CLASSES-instance Eq2 ListF where- liftEq2 _ _ Nil Nil = True- liftEq2 f g (Cons a b) (Cons a' b') = f a a' && g b b'- liftEq2 _ _ _ _ = False--instance Eq a => Eq1 (ListF a) where- liftEq = liftEq2 (==)--instance Ord2 ListF where- liftCompare2 _ _ Nil Nil = EQ- liftCompare2 _ _ Nil _ = LT- liftCompare2 _ _ _ Nil = GT- liftCompare2 f g (Cons a b) (Cons a' b') = f a a' `mappend` g b b'--instance Ord a => Ord1 (ListF a) where- liftCompare = liftCompare2 compare--instance Show a => Show1 (ListF a) where- liftShowsPrec = liftShowsPrec2 showsPrec showList--instance Show2 ListF where- liftShowsPrec2 _ _ _ _ _ Nil = showString "Nil"- liftShowsPrec2 sa _ sb _ d (Cons a b) = showParen (d > 10)- $ showString "Cons "- . sa 11 a- . showString " "- . sb 11 b--instance Read2 ListF where- liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> nil s ++ cons s- where- nil s0 = do- ("Nil", s1) <- lex s0- return (Nil, s1)- cons s0 = do- ("Cons", s1) <- lex s0- (a, s2) <- ra 11 s1- (b, s3) <- rb 11 s2- return (Cons a b, s3)--instance Read a => Read1 (ListF a) where- liftReadsPrec = liftReadsPrec2 readsPrec readList--#else-instance Eq a => Eq1 (ListF a) where eq1 = (==)-instance Ord a => Ord1 (ListF a) where compare1 = compare-instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec-instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec-#endif---- These instances cannot be auto-derived on with GHC <= 7.6-instance Functor (ListF a) where- fmap _ Nil = Nil- fmap f (Cons a b) = Cons a (f b)--instance F.Foldable (ListF a) where- foldMap _ Nil = Data.Monoid.mempty- foldMap f (Cons _ b) = f b--instance T.Traversable (ListF a) where- traverse _ Nil = pure Nil- traverse f (Cons a b) = Cons a <$> f b--instance Bi.Bifunctor ListF where- bimap _ _ Nil = Nil- bimap f g (Cons a b) = Cons (f a) (g b)--instance Bi.Bifoldable ListF where- bifoldMap _ _ Nil = mempty- bifoldMap f g (Cons a b) = mappend (f a) (g b)--instance Bi.Bitraversable ListF where- bitraverse _ _ Nil = pure Nil- bitraverse f g (Cons a b) = Cons <$> f a <*> g b- type instance Base [a] = ListF a instance Recursive [a] where project (x:xs) = Cons x xs@@ -345,6 +338,12 @@ instance Corecursive (NonEmpty a) where embed = (:|) <$> NEF.head <*> (maybe [] toList <$> NEF.tail) +type instance Base (Tree a) = TreeF a+instance Recursive (Tree a) where+ project (Node x xs) = NodeF x xs+instance Corecursive (Tree a) where+ embed (NodeF x xs) = Node x xs+ type instance Base Natural = Maybe instance Recursive Natural where project 0 = Nothing@@ -445,8 +444,9 @@ -> (a -> f (m a)) -> a -> b-ghylo w m f g = extract . h . return where- h = fmap f . w . fmap (duplicate . h . join) . m . liftM g+ghylo w m f g = f . fmap (hylo alg coalg) . g where+ coalg = fmap join . m . liftM g+ alg = fmap f . w . fmap duplicate grefold w m f g a = ghylo w m f g a futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t@@ -469,82 +469,29 @@ -- Fix ------------------------------------------------------------------------------- -newtype Fix f = Fix (f (Fix f))--unfix :: Fix f -> f (Fix f)-unfix (Fix f) = f--instance Eq1 f => Eq (Fix f) where- Fix a == Fix b = eq1 a b--instance Ord1 f => Ord (Fix f) where- compare (Fix a) (Fix b) = compare1 a b--instance Show1 f => Show (Fix f) where- showsPrec d (Fix a) =- showParen (d >= 11)- $ showString "Fix "- . showsPrec1 11 a--instance Read1 f => Read (Fix f) where- readPrec = parens $ prec 10 $ do- Ident "Fix" <- lexP- Fix <$> step (readS_to_Prec readsPrec1)--#ifdef __GLASGOW_HASKELL__-#if HAS_POLY_TYPEABLE-deriving instance Typeable Fix-deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)-#else-instance Typeable1 f => Typeable (Fix f) where- typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]- where asArgsTypeOf :: f a -> Fix f -> f a- asArgsTypeOf = const--fixTyCon :: TyCon-#if MIN_VERSION_base(4,4,0)-fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"-#else-fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"-#endif-{-# NOINLINE fixTyCon #-}--instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where- gfoldl f z (Fix a) = z Fix `f` a- toConstr _ = fixConstr- gunfold k z c = case constrIndex c of- 1 -> k (z (Fix))- _ -> error "gunfold"- dataTypeOf _ = fixDataType--fixConstr :: Constr-fixConstr = mkConstr fixDataType "Fix" [] Prefix--fixDataType :: DataType-fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]-#endif-#endif- type instance Base (Fix f) = f instance Functor f => Recursive (Fix f) where project (Fix a) = a instance Functor f => Corecursive (Fix f) where embed = Fix +-- | Convert from one recursive type to another.+--+-- >>> showTree $ hoist (\(NonEmptyF h t) -> NodeF [h] (maybeToList t)) ( 'a' :| "bcd")+-- (a (b (c d)))+-- hoist :: (Recursive s, Corecursive t) => (forall a. Base s a -> Base t a) -> s -> t hoist n = cata (embed . n) +-- | Convert from one recursive representation to another.+--+-- >>> refix ["foo", "bar"] :: Fix (ListF String)+-- Fix (Cons "foo" (Fix (Cons "bar" (Fix Nil))))+-- refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t refix = cata embed -toFix :: Recursive t => t -> Fix (Base t)-toFix = refix--fromFix :: Corecursive t => Fix (Base t) -> t-fromFix = refix-- ------------------------------------------------------------------------------- -- Lambek -------------------------------------------------------------------------------@@ -557,7 +504,6 @@ colambek :: (Recursive t, Corecursive t) => (Base t t -> t) colambek = ana (fmap project) -newtype Mu f = Mu (forall a. (f a -> a) -> a) type instance Base (Mu f) = f instance Functor f => Recursive (Mu f) where project = lambek@@ -565,27 +511,12 @@ instance Functor f => Corecursive (Mu f) where embed m = Mu (\f -> f (fmap (fold f) m)) -instance (Functor f, Eq1 f) => Eq (Mu f) where- (==) = (==) `on` toFix--instance (Functor f, Ord1 f) => Ord (Mu f) where- compare = compare `on` toFix--instance (Functor f, Show1 f) => Show (Mu f) where- showsPrec d f = showParen (d > 10) $- showString "fromFix " . showsPrec 11 (toFix f)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read1 f) => Read (Mu f) where- readPrec = parens $ prec 10 $ do- Ident "fromFix" <- lexP- fromFix <$> step readPrec-#endif---- | A specialized, faster version of 'hoist' for 'Mu'.-hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g-hoistMu n (Mu mk) = Mu $ \roll -> mk (roll . n)-+type instance Base (Nu f) = f+instance Functor f => Corecursive (Nu f) where+ embed = colambek+ ana = Nu+instance Functor f => Recursive (Nu f) where+ project (Nu f a) = Nu f <$> f a -- | Church encoded free monads are Recursive/Corecursive, in the same way that -- 'Mu' is.@@ -599,37 +530,6 @@ embed (CMTF.Pure a) = CMFC.F $ \p _ -> p a embed (CMTF.Free fr) = CMFC.F $ \p f -> f $ fmap (cmfcCata p f) fr --data Nu f where Nu :: (a -> f a) -> a -> Nu f-type instance Base (Nu f) = f-instance Functor f => Corecursive (Nu f) where- embed = colambek- ana = Nu-instance Functor f => Recursive (Nu f) where- project (Nu f a) = Nu f <$> f a--instance (Functor f, Eq1 f) => Eq (Nu f) where- (==) = (==) `on` toFix--instance (Functor f, Ord1 f) => Ord (Nu f) where- compare = compare `on` toFix--instance (Functor f, Show1 f) => Show (Nu f) where- showsPrec d f = showParen (d > 10) $- showString "fromFix " . showsPrec 11 (toFix f)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read1 f) => Read (Nu f) where- readPrec = parens $ prec 10 $ do- Ident "fromFix" <- lexP- fromFix <$> step readPrec-#endif---- | A specialized, faster version of 'hoist' for 'Nu'.-hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g-hoistNu n (Nu next seed) = Nu (n . next) seed-- zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a zygo f = gfold (distZygo f) @@ -698,11 +598,11 @@ -- | Mendler-style iteration mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c-mcata psi = psi (mcata psi) . unfix+mcata psi = psi (mcata psi) . unFix -- | Mendler-style course-of-value iteration mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c-mhisto psi = psi (mhisto psi) unfix . unfix+mhisto psi = psi (mhisto psi) unFix . unFix -- | Elgot algebras elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a@@ -797,8 +697,9 @@ -- >>> data Pair a = Pair a a deriving Functor -- -- >>> :{--- let zipWith' :: (a -> a -> b) -> [a] -> [a] -> [b]+-- let zipWith' :: forall a b. (a -> a -> b) -> [a] -> [a] -> [b] -- zipWith' f xs ys = cotransverse g (Pair xs ys) where+-- g :: Pair (ListF a c) -> ListF b (Pair c) -- g (Pair Nil _) = Nil -- g (Pair _ Nil) = Nil -- g (Pair (Cons x a) (Cons y b)) = Cons (f x y) (Pair a b)
src/Data/Functor/Foldable/TH.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP, Rank2Types #-}+{-# LANGUAGE CPP, PatternGuards, Rank2Types #-} module Data.Functor.Foldable.TH- ( makeBaseFunctor- , makeBaseFunctorWith+ ( MakeBaseFunctor(..) , BaseRules , baseRules , baseRulesType@@ -23,6 +22,14 @@ import Paths_recursion_schemes (version) #endif +#ifdef __HADDOCK__+import Data.Functor.Foldable+#endif++-- $setup+-- >>> :set -XTemplateHaskell -XTypeFamilies -XDeriveTraversable -XScopedTypeVariables+-- >>> import Data.Functor.Foldable+ -- | Build base functor with a sensible default configuration. -- -- /e.g./@@ -59,9 +66,6 @@ -- 'embed' (x :*$ y) = x :* y -- @ ----- @--- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'--- @ -- -- /Notes:/ --@@ -70,13 +74,100 @@ -- as we don't try to do better than -- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>. ---makeBaseFunctor :: Name -> DecsQ-makeBaseFunctor = makeBaseFunctorWith baseRules+-- Allowing 'makeBaseFunctor' to take both 'Name's and 'Dec's as an argument is why it exists as a method in a type class.+-- For trickier data-types, like rose-tree (see also 'Cofree'):+--+-- @+-- data Rose f a = Rose a (f (Rose f a))+-- @+--+-- we can invoke 'makeBaseFunctor' with an instance declaration+-- to provide needed context for instances. (c.f. @StandaloneDeriving@)+--+-- @+-- 'makeBaseFunctor' [d| instance Functor f => Recursive (Rose f a) |]+-- @+--+-- will create+--+-- @+-- data RoseF f a r = RoseF a (f fr)+-- deriving ('Functor', 'Foldable', 'Traversable')+--+-- type instance 'Base' (Rose f a) = RoseF f a+--+-- instance Functor f => 'Recursive' (Rose f a) where+-- 'project' (Rose x xs) = RoseF x xs+--+-- instance Functor f => 'Corecursive' (Rose f a) where+-- 'embed' (RoseF x xs) = Rose x xs+-- @+--+-- Some doctests:+--+-- >>> data Expr a = Lit a | Add (Expr a) (Expr a) | Expr a :* [Expr a]+-- >>> ; makeBaseFunctor ''Expr+--+-- >>> :t AddF+-- AddF :: r -> r -> ExprF a r+--+-- >>> data Rose f a = Rose a (f (Rose f a))+-- >>> ; makeBaseFunctor [d| instance Functor f => Recursive (Rose f a) |]+--+-- >>> :t RoseF+-- RoseF :: a -> f r -> RoseF f a r+--+-- >>> let rose = Rose 1 (Just (Rose 2 (Just (Rose 3 Nothing))))+-- >>> cata (\(RoseF x f) -> x + maybe 0 id f) rose+-- 6+--+class MakeBaseFunctor a where+ -- |+ -- @+ -- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'+ -- @+ makeBaseFunctor :: a -> DecsQ+ makeBaseFunctor = makeBaseFunctorWith baseRules --- | Build base functor with a custom configuration.-makeBaseFunctorWith :: BaseRules -> Name -> DecsQ-makeBaseFunctorWith rules name = reifyDatatype name >>= makePrimForDI rules+ -- | Build base functor with a custom configuration.+ makeBaseFunctorWith :: BaseRules -> a -> DecsQ +instance MakeBaseFunctor a => MakeBaseFunctor [a] where+ makeBaseFunctorWith rules a = fmap concat (T.traverse (makeBaseFunctorWith rules) a)++instance MakeBaseFunctor a => MakeBaseFunctor (Q a) where+ makeBaseFunctorWith rules a = makeBaseFunctorWith rules =<< a++instance MakeBaseFunctor Name where+ makeBaseFunctorWith rules name = reifyDatatype name >>= makePrimForDI rules Nothing++-- | Expects declarations of 'Recursive' or 'Corecursive' instances, e.g.+--+-- @+-- makeBaseFunctor [d| instance Functor f => Recursive (Rose f a) |]+-- @+--+-- This way we can provide a context for generated instances.+-- Note that this instance's 'makeBaseFunctor' still generates all of+-- 'Base' type instance, 'Recursive' and 'Corecursive' instances.+--+instance MakeBaseFunctor Dec where+#if MIN_VERSION_template_haskell(2,11,0)+ makeBaseFunctorWith rules (InstanceD overlaps ctx classHead []) = do+ let instanceFor = InstanceD overlaps ctx+#else+ makeBaseFunctorWith rules (InstanceD ctx classHead []) = do+ let instanceFor = InstanceD ctx+#endif+ case classHead of+ ConT u `AppT` t | u == recursiveTypeName || u == corecursiveTypeName -> do+ name <- headOfType t+ di <- reifyDatatype name+ makePrimForDI rules (Just $ \n -> instanceFor (ConT n `AppT` t)) di+ _ -> fail $ "makeBaseFunctor: expected an instance head like `ctx => Recursive (T a b ...)`, got " ++ show classHead++ makeBaseFunctorWith _ _ = fail "makeBaseFunctor(With): expected an empty instance declaration"+ -- | Rules of renaming data names data BaseRules = BaseRules { _baseRulesType :: Name -> Name@@ -119,19 +210,19 @@ isInfixName :: String -> Bool isInfixName = all isSymbolChar -makePrimForDI :: BaseRules -> DatatypeInfo -> DecsQ-makePrimForDI rules+makePrimForDI :: BaseRules+ -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance+ -> DatatypeInfo+ -> DecsQ+makePrimForDI rules mkInstance' (DatatypeInfo { datatypeName = tyName-#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTys-#else- , datatypeVars = instTys-#endif , datatypeCons = cons , datatypeVariant = variant }) = do when isDataFamInstance $ fail "makeBaseFunctor: Data families are currently not supported."- makePrimForDI' rules (variant == Newtype) tyName+ makePrimForDI' rules mkInstance'+ (variant == Newtype) tyName (map toTyVarBndr instTys) cons where isDataFamInstance = case variant of@@ -145,9 +236,11 @@ toTyVarBndr (SigT (VarT n) k) = KindedTV n k toTyVarBndr _ = error "toTyVarBndr" -makePrimForDI' :: BaseRules -> Bool -> Name -> [TyVarBndr]+makePrimForDI' :: BaseRules+ -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance+ -> Bool -> Name -> [TyVarBndr] -> [ConstructorInfo] -> DecsQ-makePrimForDI' rules isNewtype tyName vars cons = do+makePrimForDI' rules mkInstance' isNewtype tyName vars cons = do -- variable parameters let vars' = map VarT (typeVars vars) -- Name of base functor@@ -198,27 +291,26 @@ #endif -- type instance Base- baseDec <- tySynInstDCompat baseTypeName-#if MIN_VERSION_th_abstraction(0,3,0)- Nothing-#endif+ baseDec <- tySynInstDCompat baseTypeName Nothing [pure s] (pure $ conAppsT tyNameF vars') - -- instance Recursive- projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'+ let mkInstance :: Name -> [Dec] -> Dec+ mkInstance = case mkInstance' of+ Just f -> f+ Nothing -> \n -> #if MIN_VERSION_template_haskell(2,11,0)- let recursiveDec = InstanceD Nothing [] (ConT recursiveTypeName `AppT` s) [projDec]+ InstanceD Nothing [] (ConT n `AppT` s) #else- let recursiveDec = InstanceD [] (ConT recursiveTypeName `AppT` s) [projDec]+ InstanceD [] (ConT n `AppT` s) #endif + -- instance Recursive+ projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'+ let recursiveDec = mkInstance recursiveTypeName [projDec]+ -- instance Corecursive embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'-#if MIN_VERSION_template_haskell(2,11,0)- let corecursiveDec = InstanceD Nothing [] (ConT corecursiveTypeName `AppT` s) [embedDec]-#else- let corecursiveDec = InstanceD [] (ConT corecursiveTypeName `AppT` s) [embedDec]-#endif+ let corecursiveDec = mkInstance corecursiveTypeName [embedDec] -- Combine A.pure [dataDec, baseDec, recursiveDec, corecursiveDec]@@ -284,6 +376,12 @@ -- Type mangling ------------------------------------------------------------------------------- +headOfType :: Type -> Q Name+headOfType (AppT t _) = headOfType t+headOfType (VarT n) = return n+headOfType (ConT n) = return n+headOfType t = fail $ "headOfType: " ++ show t+ -- | Extract type variables typeVars :: [TyVarBndr] -> [Name] typeVars = map tvName@@ -328,9 +426,14 @@ in case variant of NormalConstructor -> NormalC name $ zip bangs ftys RecordConstructor fnames -> RecC name $ zip3 fnames bangs ftys- InfixConstructor -> let [bang1, bang2] = bangs- [fty1, fty2] = ftys- in InfixC (bang1, fty1) name (bang2, fty2)+ InfixConstructor+ | [bang1, bang2] <- bangs+ , [fty1, fty2] <- ftys+ -> InfixC (bang1, fty1) name (bang2, fty2)++ | otherwise+ -> error $ "makeBaseFunctor: Encountered an InfixConstructor "+ ++ "without exactly two fields" where #if MIN_VERSION_template_haskell(2,11,0) toBang (FieldStrictness upkd strct) = Bang (toSourceUnpackedness upkd)