recursion-schemes-5.1.3/0000755000000000000000000000000007346545000013347 5ustar0000000000000000recursion-schemes-5.1.3/.gitignore0000755000000000000000000000042707346545000015345 0ustar0000000000000000dist/ dist-newstyle/ .stack-work/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .cabal-sandbox/ cabal.sandbox.config codex.tags src/highlight.js src/style.css *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* recursion-schemes-5.1.3/.travis.yml0000755000000000000000000001525107346545000015467 0ustar0000000000000000# This Travis job script has been generated by a script via # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.2.1 # language: c dist: xenial git: submodules: false # whether to recursively clone submodules notifications: irc: channels: - "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 before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - 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: 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" before_install: - HC=/opt/ghc/bin/${CC} - HCPKG=${HC/ghc/ghc-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/') )) - echo $HCNUMVER 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 - 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" - 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. script: # test that source-distributions can be generated - ${CABAL} new-sdist all - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - rm -f cabal.project - 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" - cat cabal.project || true - cat cabal.project.local || true # 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 # REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] # EOF recursion-schemes-5.1.3/CHANGELOG.markdown0000755000000000000000000000371507346545000016413 0ustar0000000000000000## 5.1.3 [2019.04.26] * Support `th-abstraction-0.3.0.0` or later. ## 5.1.2 * Make the `Generic`-based instances to also support data constructors with zero arguments (and datatypes with zero constructors). ## 5.1.1.1 * Invalid release ## 5.1.1 * Add `cotransverse` * Add `Generic` based default implementation to `embed` and `project`. `Recursive` and `Corecursive` can be `DeriveAnyClass`-derived now, if you write the base functor by hand. ## 5.1 * Export gfutu * `distGHisto`, `ghisto`, and `gchrono` now use `Cofree (Base t)` * `distGFutu`, `gfutu`, and `gchrono` now use `Free (Base t)` * Add `hoist`, `hoistMu` and `hoistNu` * Add `transverse` and `cataA` ## 5.0.3 [2018.07.01] * Make the Template Haskell machinery look through type synonyms. * Avoid incurring some dependencies when using recent GHCs. ## 5.0.2 * Support GHC-8.2.1 * Fix Template Haskell derivation with non-default type renamer. * Add `Recursive` and `Corecursive Natural` instances, with `Base Natural = Maybe`. ## 5.0.1 * Add `Data.Functor.Foldable.TH` module, which provides derivation of base functors via Template Haskell. ## 5 * Renamed `Foldable` to `Recursive` and `Unfoldable` to `Corecursive`. With `Foldable` in `Prelude` in GHC 7.10+, having a needlessly conflicting name seemed silly. * Add support for GHC-8.0.1 * Use `Eq1`, `Ord1`, `Show1`, `Read1` to derive `Fix`, `Nu` and `Mu` `Eq`, `Ord` `Show` and `Read` instances * Remove `Prim` data family. `ListF` as a new name for `Prim [a]`, with plenty of instances, e.g. `Traversable`. * Export `unfix` * Add chronomorphisms: `chrono` and `gchrono`. * Add `distGApoT` ## 4.1.2 * Support for `free` 4.12.1 ## 4.1.1 * Support for GHC 7.10 * Fixed `para`. ## 4.1 * Support for GHC 7.7+'s generalized `Typeable`. * Faster `gapo` and `para` by exploiting sharing. ## 4.0 * Compatibility with `comonad` and `free` version 4.0 ## 3.0 * Compatibility with `transformers` 0.3 * Resolved deprecation warnings caused by changes to `Data.Typeable` recursion-schemes-5.1.3/LICENSE0000644000000000000000000000236407346545000014361 0ustar0000000000000000Copyright 2011-2015 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. 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. recursion-schemes-5.1.3/README.markdown0000755000000000000000000001306407346545000016057 0ustar0000000000000000# recursion-schemes [![Hackage](https://img.shields.io/hackage/v/recursion-schemes.svg)](https://hackage.haskell.org/package/recursion-schemes) [![Build Status](https://secure.travis-ci.org/ekmett/recursion-schemes.png?branch=master)](http://travis-ci.org/ekmett/recursion-schemes) ## What is a recursion scheme? 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. ## Benefits ### Clearer Each recursion scheme has a unique name, such as "fold" and "unfold"; or, if you prefer the fancy names, "catamorphism" and "anamorphism". If you program with others, it can be useful to have names to refer to those recursion patterns, so you can discuss which type of recursion is the most appropriate for the problem at hand. Even if you program alone, having names with which to clearly label those different solutions can help to structure your thoughts while writing recursive functions. 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. ### Faster Using recursion schemes can guide you towards optimizations. When multiple functions are composed, Haskellers often use equational reasoning in order to rearrange those compositions into equivalent compositions which compute the same result, but do so in a different, possibly more efficient manner. When the recursive and non-recursive portions of a function are written separately, more equations become available, as they have more pieces to work with. The paper [Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire](https://maartenfokkinga.github.io/utwente/mmf91m.pdf) has a lot more details on that subject. ### Safer Using recursion schemes can help you to avoid accidentally writing infinite or non-productive loops. For example, when producing an infinite list, it would be a mistake to look at the result of the recursive call in order to decide which element to produce as the head of the list, because that recursive call will itself look at its recursive call, etc., and so the information will never be returned. With `ana`, the non-recursive function you need to provide as input intentionally does not have access to the result of the recursive call, so you cannot make that mistake. ### Composable Many recursion schemes can be implemented in terms of each other. So if you notice that the non-recursive functions you provide themselves seem to share a common pattern, you might be accidentally reimplementing an existing recursion scheme which already has those common parts builtin; or maybe you have stumbled upon a new recursion scheme which does not yet have a name, and which you may want to implement yourself. One way to implement such a custom recursion scheme is to combine the features of existing recursion schemes. For example, a "paramorphism" gives the non-recursive function access to the original sub-trees, a "zygomorphism" gives that function access to auxiliary results computed from those sub-trees, and so the combined "zygomorphic paramorphism" gives that function access to both the original sub-trees and the auxiliary results. In order to construct such combinations, most of our recursion schemes come in a generalized variant, e.g. `gzygo`, and in a "distributive law transformer" variant, e.g. `distZygoT`. Just like monad transformers, distributive law transformers can be combined into stacks, and like monad transformers, the order in which you combine the layers determines how the layers interact with each other. Apply a generalized recursion scheme to a stack of distributive laws in order to obtain a recursion scheme which has both the features of the generalized recursion scheme and those of the distributive laws. ## Contributing Contributions and bug reports are welcome! Please feel free to contact us by opening a github issue or by hopping onto the #haskell IRC channel on irc.freenode.net. recursion-schemes-5.1.3/Setup.lhs0000644000000000000000000000016507346545000015161 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain recursion-schemes-5.1.3/examples/0000755000000000000000000000000007346545000015165 5ustar0000000000000000recursion-schemes-5.1.3/examples/Expr.hs0000644000000000000000000000563407346545000016447 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-} module Main where import Data.Functor.Foldable import Data.Functor.Foldable.TH import Language.Haskell.TH import GHC.Generics (Generic) import Data.List (foldl') import Test.HUnit import Data.Functor.Identity data Expr a = Lit a | Add (Expr a) (Expr a) | Expr a :* [Expr a] deriving (Show) makeBaseFunctor ''Expr data Expr2 a = Lit2 a | Add2 (Expr2 a) (Expr2 a) deriving (Show) makeBaseFunctorWith (runIdentity $ return baseRules >>= baseRulesCon (\_-> Identity $ mkName . (++ "'") . nameBase) >>= baseRulesType (\_ -> Identity $ mkName . (++ "_") . nameBase) ) ''Expr2 data Expr3 a = Unit3 | Lit3 a | Add3 (Expr3 a) (Expr3 a) | OpA (Expr3 a) (Expr3 a) Int | OpB (Expr3 a) (Expr3 a) Char | OpC (Expr3 a) (Expr3 a) Bool | OpD (Expr3 a) (Expr3 a) Int | OpE (Expr3 a) (Expr3 a) Char | OpF (Expr3 a) (Expr3 a) Bool Bool Bool deriving (Show, Generic) data Expr3F a b = Unit3F | Lit3F a | Add3F b b | OpAF b b Int | OpBF b b Char | OpCF b b Bool | OpDF b b Int | OpEF b b Char | OpFF b b Bool Bool Bool deriving (Show, Generic, Functor) type instance Base (Expr3 a) = (Expr3F a) instance Recursive (Expr3 a) instance Corecursive (Expr3 a) expr1 :: Expr Int expr1 = Add (Lit 2) (Lit 3 :* [Lit 4]) -- This is to test newtype derivation -- -- Kind of a list newtype L a = L { getL :: Maybe (a, L a) } deriving (Show, Eq) makeBaseFunctor ''L cons :: a -> L a -> L a cons x xs = L (Just (x, xs)) nil :: L a nil = L Nothing -- Test #33 data Tree a = Node {rootLabel :: a, subForest :: Forest a} deriving (Show) type Forest a = [Tree a] makeBaseFunctor ''Tree main :: IO () main = do let expr2 = ana divCoalg 55 :: Expr Int 14 @=? cata evalAlg expr1 55 @=? cata evalAlg expr2 let lBar = cons 'b' $ cons 'a' $ cons 'r' $ nil "bar" @=? cata lAlg lBar lBar @=? ana lCoalg "bar" let expr3 = Add2 (Lit2 21) $ Add2 (Lit2 11) (Lit2 10) 42 @=? cata evalAlg2 expr3 let expr4 = Node 5 [Node 6 [Node 7 []], Node 8 [Node 9 []]] 35 @=? cata treeAlg expr4 where -- Type signatures to test name generation evalAlg :: ExprF Int Int -> Int evalAlg (LitF x) = x evalAlg (AddF x y) = x + y evalAlg (x :*$ y) = foldl' (*) x y evalAlg2 :: Expr2_ Int Int -> Int evalAlg2 (Lit2' x) = x evalAlg2 (Add2' x y) = x + y divCoalg x | x < 5 = LitF x | even x = 2 :*$ [x'] | otherwise = AddF x' (x - x') where x' = x `div` 2 lAlg (LF Nothing) = [] lAlg (LF (Just (x, xs))) = x : xs lCoalg [] = LF { getLF = Nothing } -- to test field renamer lCoalg (x : xs) = LF { getLF = Just (x, xs) } treeAlg :: TreeF Int Int -> Int treeAlg (NodeF r f) = r + sum f recursion-schemes-5.1.3/include/0000755000000000000000000000000007346545000014772 5ustar0000000000000000recursion-schemes-5.1.3/include/recursion-schemes-common.h0000755000000000000000000000121707346545000022073 0ustar0000000000000000#ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_transformers #define MIN_VERSION_transformers(x,y,z) 1 #endif #ifndef MIN_VERSION_transformers_compat #define MIN_VERSION_transformers_compat(x,y,z) 0 #endif #if MIN_VERSION_base(4,9,0) #define LIFTED_FUNCTOR_CLASSES 1 #elif MIN_VERSION_transformers(0,5,0) #define LIFTED_FUNCTOR_CLASSES 1 #elif MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) #define LIFTED_FUNCTOR_CLASSES 1 #endif #define HAS_GENERIC (__GLASGOW_HASKELL__ >= 702) #define HAS_GENERIC1 (__GLASGOW_HASKELL__ >= 706) #define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0) recursion-schemes-5.1.3/recursion-schemes.cabal0000644000000000000000000000651307346545000017776 0ustar0000000000000000name: recursion-schemes category: Control, Recursion version: 5.1.3 license: BSD2 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: "Samuel Gélineau" , "Oleg Grenrus" , "Ryan Scott" stability: provisional homepage: http://github.com/ekmett/recursion-schemes/ bug-reports: http://github.com/ekmett/recursion-schemes/issues copyright: Copyright (C) 2008-2015 Edward A. Kmett 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 build-type: Simple extra-source-files: .travis.yml CHANGELOG.markdown .gitignore README.markdown include/recursion-schemes-common.h source-repository head type: git location: git://github.com/ekmett/recursion-schemes.git flag template-haskell description: About Template Haskell derivations manual: True default: True library other-extensions: CPP TypeFamilies Rank2Types FlexibleContexts FlexibleInstances GADTs StandaloneDeriving UndecidableInstances hs-source-dirs: src include-dirs: include -- includes: recursion-schemes-common.h build-depends: base >= 4.5 && < 5, comonad >= 4 && < 6, free >= 4 && < 6, transformers >= 0.3.0.0 && < 1 if !impl(ghc >= 8.2) build-depends: bifunctors >= 4 && < 6 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.10 && < 1 if impl(ghc < 7.5) build-depends: ghc-prim -- Following two conditionals aren't inverses (there are other compilers than GHC) -- -- We enforce the fact that with GHC-7.10 -- we have at least transformers-0.4.2.0 (the bundled one) -- which has 'Data.Functor.Classes' module. (transformers-0.3 doesn't have) if impl(ghc >= 7.10) build-depends: transformers >= 0.4.2.0 if !impl(ghc >= 7.10) build-depends: nats, transformers-compat >= 0.3 && < 1 exposed-modules: Data.Functor.Base Data.Functor.Foldable if flag(template-haskell) build-depends: template-haskell >= 2.5.0.0 && < 2.15, base-orphans >= 0.5.4 && < 0.9, th-abstraction >= 0.2.4 && < 0.4 exposed-modules: Data.Functor.Foldable.TH other-modules: Paths_recursion_schemes ghc-options: -Wall test-suite Expr type: exitcode-stdio-1.0 main-is: Expr.hs hs-source-dirs: examples ghc-options: -Wall -threaded build-depends: base, HUnit <1.7, recursion-schemes, template-haskell, transformers >= 0.2 && < 1 if impl(ghc < 7.5) build-depends: ghc-prim recursion-schemes-5.1.3/src/Data/Functor/0000755000000000000000000000000007346545000016427 5ustar0000000000000000recursion-schemes-5.1.3/src/Data/Functor/Base.hs0000644000000000000000000000624207346545000017641 0ustar0000000000000000{-# LANGUAGE CPP #-} #include "recursion-schemes-common.h" #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} #if HAS_GENERIC {-# LANGUAGE DeriveGeneric #-} #endif #endif -- | Base Functors for standard types not already expressed as a fixed point. module Data.Functor.Base ( NonEmptyF(..) ) where #ifdef __GLASGOW_HASKELL__ import Data.Data (Typeable) #if HAS_GENERIC import GHC.Generics (Generic) #endif #if HAS_GENERIC1 import GHC.Generics (Generic1) #endif #endif import Control.Applicative import Data.Monoid import Data.Functor.Classes ( Eq1(..), Ord1(..), Show1(..), Read1(..) #ifdef LIFTED_FUNCTOR_CLASSES , Eq2(..), Ord2(..), Show2(..), Read2(..) #endif ) 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 Prelude hiding (head, tail) -- | Base Functor for 'Data.List.NonEmpty' data NonEmptyF a b = NonEmptyF { head :: a, tail :: Maybe b } deriving (Eq,Ord,Show,Read,Typeable #if HAS_GENERIC , Generic #endif #if HAS_GENERIC1 , Generic1 #endif ) #ifdef LIFTED_FUNCTOR_CLASSES instance Eq2 NonEmptyF where liftEq2 f g (NonEmptyF a mb) (NonEmptyF a' mb') = f a a' && liftEq g mb mb' instance Eq a => Eq1 (NonEmptyF a) where liftEq = liftEq2 (==) instance Ord2 NonEmptyF where liftCompare2 f g (NonEmptyF a mb) (NonEmptyF a' mb') = f a a' `mappend` liftCompare g mb mb' instance Ord a => Ord1 (NonEmptyF a) where liftCompare = liftCompare2 compare instance Show a => Show1 (NonEmptyF a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show2 NonEmptyF where liftShowsPrec2 sa _ sb slb d (NonEmptyF a b) = showParen (d > 10) $ showString "NonEmptyF " . sa 11 a . showString " " . liftShowsPrec sb slb 11 b instance Read2 NonEmptyF where liftReadsPrec2 ra _ rb rlb d = readParen (d > 10) $ \s -> cons s where cons s0 = do ("NonEmptyF", s1) <- lex s0 (a, s2) <- ra 11 s1 (mb, s3) <- liftReadsPrec rb rlb 11 s2 return (NonEmptyF a mb, s3) instance Read a => Read1 (NonEmptyF a) where liftReadsPrec = liftReadsPrec2 readsPrec readList #else instance Eq a => Eq1 (NonEmptyF a) where eq1 = (==) instance Ord a => Ord1 (NonEmptyF a) where compare1 = compare instance Show a => Show1 (NonEmptyF a) where showsPrec1 = showsPrec instance Read a => Read1 (NonEmptyF a) where readsPrec1 = readsPrec #endif -- These instances cannot be auto-derived on with GHC <= 7.6 instance Functor (NonEmptyF a) where fmap f = NonEmptyF <$> head <*> (fmap f . tail) instance F.Foldable (NonEmptyF a) where foldMap f = F.foldMap f . tail instance T.Traversable (NonEmptyF a) where traverse f = fmap <$> (NonEmptyF . head) <*> (T.traverse f . tail) instance Bi.Bifunctor NonEmptyF where bimap f g = NonEmptyF <$> (f . head) <*> (fmap g . tail) instance Bi.Bifoldable NonEmptyF where bifoldMap f g = merge <$> (f . head) <*> (fmap g . tail) where merge x my = maybe x (mappend x) my instance Bi.Bitraversable NonEmptyF where bitraverse f g = liftA2 NonEmptyF <$> (f . head) <*> (T.traverse g . tail) recursion-schemes-5.1.3/src/Data/Functor/Foldable.hs0000644000000000000000000006220007346545000020473 0ustar0000000000000000{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-} #include "recursion-schemes-common.h" #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE ConstrainedClassMethods #-} #endif #if HAS_GENERIC {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables, DefaultSignatures, MultiParamTypeClasses, TypeOperators #-} #endif #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : "Samuel Gélineau" , -- "Oleg Grenrus" , -- "Ryan Scott" -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Functor.Foldable ( -- * Base functors for fixed points Base , ListF(..) -- * Fixed points , Fix(..), unfix , Mu(..), hoistMu , Nu(..), hoistNu -- * Folding , Recursive(..) -- ** Combinators , gapo , gcata , zygo , gzygo , histo , ghisto , futu , gfutu , chrono , gchrono -- ** Distributive laws , distCata , distPara , distParaT , distZygo , distZygoT , distHisto , distGHisto , distFutu , distGFutu -- * Unfolding , Corecursive(..) -- ** Combinators , gana -- ** Distributive laws , distAna , distApo , distGApo , distGApoT -- * Refolding , hylo , ghylo -- ** Changing representation , hoist , refix -- * Common names , fold, gfold , unfold, gunfold , refold, grefold -- * Mendler-style , mcata , mhisto -- * Elgot (co)algebras , elgot , coelgot -- * Zygohistomorphic prepromorphisms , zygoHistoPrepro -- * Effectful combinators , cataA , transverse , cotransverse ) where import Control.Applicative import Control.Comonad import Control.Comonad.Trans.Class import Control.Comonad.Trans.Env import qualified Control.Comonad.Cofree as Cofree import Control.Comonad.Cofree (Cofree(..)) import Control.Comonad.Trans.Cofree (CofreeF, CofreeT(..)) import qualified Control.Comonad.Trans.Cofree as CCTC import Control.Monad (liftM, join) import Control.Monad.Free (Free(..)) import qualified Control.Monad.Free.Church as CMFC import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Free (FreeF, FreeT(..)) 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 #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(..)) -- $setup -- >>> :set -XDeriveFunctor -- >>> import Control.Monad (void) -- >>> import Data.Char (toUpper) type family Base t :: * -> * class Functor (Base t) => Recursive t where 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 cata :: (Base t a -> a) -- ^ a (Base t)-algebra -> t -- ^ fixed point -> a -- ^ result cata f = c where c = f . fmap c . project para :: (Base t (t, a) -> a) -> t -> a para t = p where p x = t . fmap ((,) <*> p) $ project x gpara :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (EnvT t w a) -> a) -> t -> a gpara t = gzygo embed t -- | Fokkinga's prepromorphism prepro :: Corecursive t => (forall b. Base t b -> Base t b) -> (Base t a -> a) -> t -> a prepro e f = c where c = f . fmap (c . hoist e) . project --- | A generalized prepromorphism gprepro :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (forall c. Base t c -> Base t c) -> (Base t (w a) -> a) -> t -> a gprepro k e f = extract . c where c = fmap f . k . fmap (duplicate . c . hoist e) . project distPara :: Corecursive t => Base t (t, a) -> (t, Base t a) distPara = distZygo embed 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 class Functor (Base t) => Corecursive t where 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 ana :: (a -> Base t a) -- ^ a (Base t)-coalgebra -> a -- ^ seed -> t -- ^ resulting fixed point ana g = a where a = embed . fmap a . g apo :: (a -> Base t (Either t a)) -> a -> t apo g = a where a = embed . (fmap (either id a)) . g -- | Fokkinga's postpromorphism postpro :: Recursive t => (forall b. Base t b -> Base t b) -- natural transformation -> (a -> Base t a) -- a (Base t)-coalgebra -> a -- seed -> t postpro e g = a where a = embed . fmap (hoist e . a) . g -- | A generalized postpromorphism gpostpro :: (Recursive t, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -- distributive law -> (forall c. Base t c -> Base t c) -- natural transformation -> (a -> Base t (m a)) -- a (Base t)-m-coalgebra -> a -- seed -> t gpostpro k e g = a . return where a = embed . fmap (hoist e . a . join) . k . liftM g hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b hylo f g = h where h = f . fmap h . g fold :: Recursive t => (Base t a -> a) -> t -> a fold = cata unfold :: Corecursive t => (a -> Base t a) -> a -> t unfold = ana 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 project [] = Nil para f (x:xs) = f (Cons x (xs, para f xs)) para f [] = f Nil instance Corecursive [a] where embed (Cons x xs) = x:xs embed Nil = [] apo f a = case f a of Cons x (Left xs) -> x : xs Cons x (Right b) -> x : apo f b Nil -> [] type instance Base (NonEmpty a) = NonEmptyF a instance Recursive (NonEmpty a) where project (x:|xs) = NonEmptyF x $ nonEmpty xs instance Corecursive (NonEmpty a) where embed = (:|) <$> NEF.head <*> (maybe [] toList <$> NEF.tail) type instance Base Natural = Maybe instance Recursive Natural where project 0 = Nothing project n = Just (n - 1) instance Corecursive Natural where embed = maybe 0 (+1) -- | Cofree comonads are Recursive/Corecursive type instance Base (Cofree f a) = CofreeF f a instance Functor f => Recursive (Cofree f a) where project (x :< xs) = x CCTC.:< xs instance Functor f => Corecursive (Cofree f a) where embed (x CCTC.:< xs) = x :< xs -- | Cofree tranformations of comonads are Recursive/Corecusive type instance Base (CofreeT f w a) = Compose w (CofreeF f a) instance (Functor w, Functor f) => Recursive (CofreeT f w a) where project = Compose . runCofreeT instance (Functor w, Functor f) => Corecursive (CofreeT f w a) where embed = CofreeT . getCompose -- | Free monads are Recursive/Corecursive type instance Base (Free f a) = FreeF f a instance Functor f => Recursive (Free f a) where project (Pure a) = CMTF.Pure a project (Free f) = CMTF.Free f improveF :: Functor f => CMFC.F f a -> Free f a improveF x = CMFC.improve (CMFC.fromF x) -- | It may be better to work with the instance for `CMFC.F` directly. instance Functor f => Corecursive (Free f a) where embed (CMTF.Pure a) = Pure a embed (CMTF.Free f) = Free f ana coalg = improveF . ana coalg postpro nat coalg = improveF . postpro nat coalg gpostpro dist nat coalg = improveF . gpostpro dist nat coalg -- | Free transformations of monads are Recursive/Corecursive type instance Base (FreeT f m a) = Compose m (FreeF f a) instance (Functor m, Functor f) => Recursive (FreeT f m a) where project = Compose . runFreeT instance (Functor m, Functor f) => Corecursive (FreeT f m a) where embed = FreeT . getCompose -- If you are looking for instances for the free MonadPlus, please use the -- instance for FreeT f []. -- If you are looking for instances for the free alternative and free -- applicative, I'm sorry to disapoint you but you won't find them in this -- package. They can be considered recurive, but using non-uniform recursion; -- this package only implements uniformly recursive folds / unfolds. -- | Example boring stub for non-recursive data types type instance Base (Maybe a) = Const (Maybe a) instance Recursive (Maybe a) where project = Const instance Corecursive (Maybe a) where embed = getConst -- | Example boring stub for non-recursive data types type instance Base (Either a b) = Const (Either a b) instance Recursive (Either a b) where project = Const instance Corecursive (Either a b) where embed = getConst -- | A generalized catamorphism gfold, gcata :: (Recursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -- ^ a distributive law -> (Base t (w a) -> a) -- ^ a (Base t)-w-algebra -> t -- ^ fixed point -> a gcata k g = g . extract . c where c = k . fmap (duplicate . fmap g . c) . project gfold k g t = gcata k g t distCata :: Functor f => f (Identity a) -> Identity (f a) distCata = Identity . fmap runIdentity -- | A generalized anamorphism gunfold, gana :: (Corecursive t, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -- ^ a distributive law -> (a -> Base t (m a)) -- ^ a (Base t)-m-coalgebra -> a -- ^ seed -> t gana k f = a . return . f where a = embed . fmap (a . liftM f . join) . k gunfold k f t = gana k f t distAna :: Functor f => Identity (f a) -> f (Identity a) distAna = fmap Identity . runIdentity -- | A generalized hylomorphism grefold, ghylo :: (Comonad w, Functor f, Monad m) => (forall c. f (w c) -> w (f c)) -> (forall d. m (f d) -> f (m d)) -> (f (w b) -> b) -> (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 grefold w m f g a = ghylo w m f g a futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t futu = gana distFutu gfutu :: (Corecursive t, Functor m, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -> (a -> Base t (FreeT (Base t) m a)) -> a -> t gfutu g = gana (distGFutu g) distFutu :: Functor f => Free f (f a) -> f (Free f a) distFutu (Pure fx) = Pure <$> fx distFutu (Free ff) = Free . distFutu <$> ff distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> FreeT f h (f a) -> f (FreeT f h a) distGFutu k = d where d = fmap FreeT . k . fmap d' . runFreeT d' (CMTF.Pure ff) = CMTF.Pure <$> ff d' (CMTF.Free ff) = CMTF.Free . d <$> ff ------------------------------------------------------------------------------- -- 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 hoist :: (Recursive s, Corecursive t) => (forall a. Base s a -> Base t a) -> s -> t hoist n = cata (embed . n) 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 ------------------------------------------------------------------------------- -- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed' lambek :: (Recursive t, Corecursive t) => (t -> Base t t) lambek = cata (fmap embed) -- | The dual of Lambek's lemma, provides a default definition for 'embed' in terms of 'ana' and 'project' 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 cata f (Mu g) = g f 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) -- | Church encoded free monads are Recursive/Corecursive, in the same way that -- 'Mu' is. type instance Base (CMFC.F f a) = FreeF f a cmfcCata :: (a -> r) -> (f r -> r) -> CMFC.F f a -> r cmfcCata p f (CMFC.F run) = run p f instance Functor f => Recursive (CMFC.F f a) where project = lambek cata f = cmfcCata (f . CMTF.Pure) (f . CMTF.Free) instance Functor f => Corecursive (CMFC.F f a) where 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) distZygo :: Functor f => (f b -> b) -- An f-algebra -> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion distZygo g m = (g (fmap fst m), fmap snd m) gzygo :: (Recursive t, Comonad w) => (Base t b -> b) -> (forall c. Base t (w c) -> w (Base t c)) -> (Base t (EnvT b w a) -> a) -> t -> a gzygo f w = gfold (distZygoT f w) distZygoT :: (Functor f, Comonad w) => (f b -> b) -- An f-w-algebra to use for semi-mutual recursion -> (forall c. f (w c) -> w (f c)) -- A base Distributive law -> f (EnvT b w a) -> EnvT b w (f a) -- A new distributive law that adds semi-mutual recursion distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe)) where getEnv (EnvT e _) = e gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t gapo g = gunfold (distGApo g) distApo :: Recursive t => Either t (Base t a) -> Base t (Either t a) distApo = distGApo project distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a) distGApo f = either (fmap Left . f) (fmap Right) distGApoT :: (Functor f, Functor m) => (b -> f b) -> (forall c. m (f c) -> f (m c)) -> ExceptT b m (f a) -> f (ExceptT b m a) distGApoT g k = fmap ExceptT . k . fmap (distGApo g) . runExceptT -- | Course-of-value iteration histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a histo = gcata distHisto ghisto :: (Recursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (CofreeT (Base t) w a) -> a) -> t -> a ghisto g = gcata (distGHisto g) distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a) distHisto fc = fmap extract fc :< fmap (distHisto . Cofree.unwrap) fc distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (CofreeT f h a) -> CofreeT f h (f a) distGHisto k = d where d = CofreeT . fmap (\fc -> fmap CCTC.headF fc CCTC.:< fmap (d . CCTC.tailF) fc) . k . fmap runCofreeT chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b) chrono = ghylo distHisto distFutu gchrono :: (Functor f, Functor w, Functor m, Comonad w, Monad m) => (forall c. f (w c) -> w (f c)) -> (forall c. m (f c) -> f (m c)) -> (f (CofreeT f w b) -> b) -> (a -> f (FreeT f m a)) -> (a -> b) gchrono w m = ghylo (distGHisto w) (distGFutu m) -- | Mendler-style iteration mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c 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 -- | Elgot algebras elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a elgot phi psi = h where h = (id ||| phi . fmap h) . psi -- | Elgot coalgebras: coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b coelgot phi psi = h where h = phi . (id &&& fmap h . psi) -- | Zygohistomorphic prepromorphisms: -- -- A corrected and modernized version of zygoHistoPrepro :: (Corecursive t, Recursive t) => (Base t b -> b) -> (forall c. Base t c -> Base t c) -> (Base t (EnvT b (Cofree (Base t)) a) -> a) -> t -> a zygoHistoPrepro f g t = gprepro (distZygoT f distHisto) g t ------------------------------------------------------------------------------- -- Effectful combinators ------------------------------------------------------------------------------- -- | Effectful 'fold'. -- -- This is a type specialisation of 'cata'. -- -- An example terminating a recursion immediately: -- -- >>> cataA (\alg -> case alg of { Nil -> pure (); Cons a _ -> Const [a] }) "hello" -- Const "h" -- cataA :: (Recursive t) => (Base t (f a) -> f a) -> t -> f a cataA = cata -- | An effectful version of 'hoist'. -- -- Properties: -- -- @ -- 'transverse' 'sequenceA' = 'pure' -- @ -- -- Examples: -- -- The weird type of first argument allows user to decide -- an order of sequencing: -- -- >>> transverse (\x -> print (void x) *> sequence x) "foo" :: IO String -- Cons 'f' () -- Cons 'o' () -- Cons 'o' () -- Nil -- "foo" -- -- >>> transverse (\x -> sequence x <* print (void x)) "foo" :: IO String -- Nil -- Cons 'o' () -- Cons 'o' () -- Cons 'f' () -- "foo" -- transverse :: (Recursive s, Corecursive t, Functor f) => (forall a. Base s (f a) -> f (Base t a)) -> s -> f t transverse n = cata (fmap embed . n) -- | A coeffectful version of 'hoist'. -- -- Properties: -- -- @ -- 'cotransverse' 'distAna' = 'runIdentity' -- @ -- -- Examples: -- -- Stateful transformations: -- -- >>> :{ -- cotransverse -- (\(u, b) -> case b of -- Nil -> Nil -- Cons x a -> Cons (if u then toUpper x else x) (not u, a)) -- (True, "foobar") :: String -- :} -- "FoObAr" -- -- We can implement a variant of `zipWith` -- -- >>> data Pair a = Pair a a deriving Functor -- -- >>> :{ -- let zipWith' :: (a -> a -> b) -> [a] -> [a] -> [b] -- zipWith' f xs ys = cotransverse g (Pair xs ys) where -- g (Pair Nil _) = Nil -- g (Pair _ Nil) = Nil -- g (Pair (Cons x a) (Cons y b)) = Cons (f x y) (Pair a b) -- :} -- -- >>> zipWith' (*) [1,2,3] [4,5,6] -- [4,10,18] -- -- >>> zipWith' (*) [1,2,3] [4,5,6,8] -- [4,10,18] -- -- >>> zipWith' (*) [1,2,3,3] [4,5,6] -- [4,10,18] -- cotransverse :: (Recursive s, Corecursive t, Functor f) => (forall a. f (Base s a) -> Base t (f a)) -> f s -> t cotransverse n = ana (n . fmap project) ------------------------------------------------------------------------------- -- GCoerce ------------------------------------------------------------------------------- class GCoerce f g where gcoerce :: f a -> g a instance GCoerce f g => GCoerce (M1 i c f) (M1 i c' g) where gcoerce (M1 x) = M1 (gcoerce x) -- R changes to/from P with GHC-7.4.2 at least. instance GCoerce (K1 i c) (K1 j c) where gcoerce = K1 . unK1 instance GCoerce U1 U1 where gcoerce = id instance GCoerce V1 V1 where gcoerce = id instance (GCoerce f g, GCoerce f' g') => GCoerce (f :*: f') (g :*: g') where gcoerce (x :*: y) = gcoerce x :*: gcoerce y instance (GCoerce f g, GCoerce f' g') => GCoerce (f :+: f') (g :+: g') where gcoerce (L1 x) = L1 (gcoerce x) gcoerce (R1 x) = R1 (gcoerce x) recursion-schemes-5.1.3/src/Data/Functor/Foldable/0000755000000000000000000000000007346545000020137 5ustar0000000000000000recursion-schemes-5.1.3/src/Data/Functor/Foldable/TH.hs0000644000000000000000000003464607346545000021023 0ustar0000000000000000{-# LANGUAGE CPP, Rank2Types #-} module Data.Functor.Foldable.TH ( makeBaseFunctor , makeBaseFunctorWith , BaseRules , baseRules , baseRulesType , baseRulesCon , baseRulesField ) where import Control.Applicative as A import Control.Monad import Data.Traversable as T import Data.Functor.Identity import Language.Haskell.TH import Language.Haskell.TH.Datatype as TH.Abs import Language.Haskell.TH.Syntax (mkNameG_tc, mkNameG_v) import Data.Char (GeneralCategory (..), generalCategory) import Data.Orphans () #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_recursion_schemes (version) #endif -- | Build base functor with a sensible default configuration. -- -- /e.g./ -- -- @ -- data Expr a -- = Lit a -- | Add (Expr a) (Expr a) -- | Expr a :* [Expr a] -- deriving (Show) -- -- 'makeBaseFunctor' ''Expr -- @ -- -- will create -- -- @ -- data ExprF a x -- = LitF a -- | AddF x x -- | x :*$ [x] -- deriving ('Functor', 'Foldable', 'Traversable') -- -- type instance 'Base' (Expr a) = ExprF a -- -- instance 'Recursive' (Expr a) where -- 'project' (Lit x) = LitF x -- 'project' (Add x y) = AddF x y -- 'project' (x :* y) = x :*$ y -- -- instance 'Corecursive' (Expr a) where -- 'embed' (LitF x) = Lit x -- 'embed' (AddF x y) = Add x y -- 'embed' (x :*$ y) = x :* y -- @ -- -- @ -- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules' -- @ -- -- /Notes:/ -- -- 'makeBaseFunctor' works properly only with ADTs. -- Existentials and GADTs aren't supported, -- as we don't try to do better than -- . -- makeBaseFunctor :: Name -> DecsQ makeBaseFunctor = makeBaseFunctorWith baseRules -- | Build base functor with a custom configuration. makeBaseFunctorWith :: BaseRules -> Name -> DecsQ makeBaseFunctorWith rules name = reifyDatatype name >>= makePrimForDI rules -- | Rules of renaming data names data BaseRules = BaseRules { _baseRulesType :: Name -> Name , _baseRulesCon :: Name -> Name , _baseRulesField :: Name -> Name } -- | Default 'BaseRules': append @F@ or @$@ to data type, constructors and field names. baseRules :: BaseRules baseRules = BaseRules { _baseRulesType = toFName , _baseRulesCon = toFName , _baseRulesField = toFName } -- | How to name the base functor type. -- -- Default is to append @F@ or @$@. baseRulesType :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules baseRulesType f rules = (\x -> rules { _baseRulesType = x }) <$> f (_baseRulesType rules) -- | How to rename the base functor type constructors. -- -- Default is to append @F@ or @$@. baseRulesCon :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules baseRulesCon f rules = (\x -> rules { _baseRulesCon = x }) <$> f (_baseRulesCon rules) -- | How to rename the base functor type field names (in records). -- -- Default is to append @F@ or @$@. baseRulesField :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules baseRulesField f rules = (\x -> rules { _baseRulesField = x }) <$> f (_baseRulesField rules) toFName :: Name -> Name toFName = mkName . f . nameBase where f name | isInfixName name = name ++ "$" | otherwise = name ++ "F" isInfixName :: String -> Bool isInfixName = all isSymbolChar makePrimForDI :: BaseRules -> DatatypeInfo -> DecsQ makePrimForDI rules (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 (map toTyVarBndr instTys) cons where isDataFamInstance = case variant of DataInstance -> True NewtypeInstance -> True Datatype -> False Newtype -> False toTyVarBndr :: Type -> TyVarBndr toTyVarBndr (VarT n) = PlainTV n toTyVarBndr (SigT (VarT n) k) = KindedTV n k toTyVarBndr _ = error "toTyVarBndr" makePrimForDI' :: BaseRules -> Bool -> Name -> [TyVarBndr] -> [ConstructorInfo] -> DecsQ makePrimForDI' rules isNewtype tyName vars cons = do -- variable parameters let vars' = map VarT (typeVars vars) -- Name of base functor let tyNameF = _baseRulesType rules tyName -- Recursive type let s = conAppsT tyName vars' -- Additional argument rName <- newName "r" let r = VarT rName -- Vars let varsF = vars ++ [PlainTV rName] -- #33 cons' <- traverse (conTypeTraversal resolveTypeSynonyms) cons let consF = toCon . conNameMap (_baseRulesCon rules) . conFieldNameMap (_baseRulesField rules) . conTypeMap (substType s r) <$> cons' -- Data definition let dataDec = case consF of #if MIN_VERSION_template_haskell(2,11,0) [conF] | isNewtype -> NewtypeD [] tyNameF varsF Nothing conF deriveds _ -> DataD [] tyNameF varsF Nothing consF deriveds #else [conF] | isNewtype -> NewtypeD [] tyNameF varsF conF deriveds _ -> DataD [] tyNameF varsF consF deriveds #endif where deriveds = #if MIN_VERSION_template_haskell(2,12,0) [DerivClause Nothing [ ConT functorTypeName , ConT foldableTypeName , ConT traversableTypeName ]] #elif MIN_VERSION_template_haskell(2,11,0) [ ConT functorTypeName , ConT foldableTypeName , ConT traversableTypeName ] #else [functorTypeName, foldableTypeName, traversableTypeName] #endif -- type instance Base baseDec <- tySynInstDCompat baseTypeName #if MIN_VERSION_th_abstraction(0,3,0) Nothing #endif [pure s] (pure $ conAppsT tyNameF vars') -- instance Recursive projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons' #if MIN_VERSION_template_haskell(2,11,0) let recursiveDec = InstanceD Nothing [] (ConT recursiveTypeName `AppT` s) [projDec] #else let recursiveDec = InstanceD [] (ConT recursiveTypeName `AppT` s) [projDec] #endif -- 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 -- Combine A.pure [dataDec, baseDec, recursiveDec, corecursiveDec] -- | makes clauses to rename constructors mkMorphism :: (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Clause] mkMorphism nFrom nTo args = for args $ \ci -> do let n = constructorName ci fs <- replicateM (length (constructorFields ci)) (newName "x") pure $ Clause [ConP (nFrom n) (map VarP fs)] -- patterns (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body [] -- where dec ------------------------------------------------------------------------------- -- Traversals ------------------------------------------------------------------------------- conNameTraversal :: Traversal' ConstructorInfo Name conNameTraversal = lens constructorName (\s v -> s { constructorName = v }) conFieldNameTraversal :: Traversal' ConstructorInfo Name conFieldNameTraversal = lens constructorVariant (\s v -> s { constructorVariant = v }) . conVariantTraversal where conVariantTraversal :: Traversal' ConstructorVariant Name conVariantTraversal _ NormalConstructor = pure NormalConstructor conVariantTraversal _ InfixConstructor = pure InfixConstructor conVariantTraversal f (RecordConstructor fs) = RecordConstructor <$> traverse f fs conTypeTraversal :: Traversal' ConstructorInfo Type conTypeTraversal = lens constructorFields (\s v -> s { constructorFields = v }) . traverse conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo conNameMap = over conNameTraversal conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo conFieldNameMap = over conFieldNameTraversal conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo conTypeMap = over conTypeTraversal ------------------------------------------------------------------------------- -- Lenses ------------------------------------------------------------------------------- type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s lens :: (s -> a) -> (s -> a -> s) -> Lens' s a lens sa sas afa s = sas s <$> afa (sa s) {-# INLINE lens #-} over :: Traversal' s a -> (a -> a) -> s -> s over l f = runIdentity . l (Identity . f) {-# INLINE over #-} ------------------------------------------------------------------------------- -- Type mangling ------------------------------------------------------------------------------- -- | Extract type variables typeVars :: [TyVarBndr] -> [Name] typeVars = map tvName -- | Apply arguments to a type constructor. conAppsT :: Name -> [Type] -> Type conAppsT conName = foldl AppT (ConT conName) -- | Provides substitution for types substType :: Type -> Type -> Type -> Type substType a b = go where go x | x == a = b go (VarT n) = VarT n go (AppT l r) = AppT (go l) (go r) go (ForallT xs ctx t) = ForallT xs ctx (go t) -- This may fail with kind error go (SigT t k) = SigT (go t) k #if MIN_VERSION_template_haskell(2,11,0) go (InfixT l n r) = InfixT (go l) n (go r) go (UInfixT l n r) = UInfixT (go l) n (go r) go (ParensT t) = ParensT (go t) #endif -- Rest are unchanged go x = x toCon :: ConstructorInfo -> Con toCon (ConstructorInfo { constructorName = name , constructorVars = vars , constructorContext = ctxt , constructorFields = ftys , constructorStrictness = fstricts , constructorVariant = variant }) | not (null vars && null ctxt) = error "makeBaseFunctor: GADTs are not currently supported." | otherwise = let bangs = map toBang fstricts 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) where #if MIN_VERSION_template_haskell(2,11,0) toBang (FieldStrictness upkd strct) = Bang (toSourceUnpackedness upkd) (toSourceStrictness strct) where toSourceUnpackedness :: Unpackedness -> SourceUnpackedness toSourceUnpackedness UnspecifiedUnpackedness = NoSourceUnpackedness toSourceUnpackedness NoUnpack = SourceNoUnpack toSourceUnpackedness Unpack = SourceUnpack toSourceStrictness :: Strictness -> SourceStrictness toSourceStrictness UnspecifiedStrictness = NoSourceStrictness toSourceStrictness Lazy = SourceLazy toSourceStrictness TH.Abs.Strict = SourceStrict #else -- On old versions of Template Haskell, there isn't as rich of strictness -- information available, so the conversion is somewhat lossy. We try our -- best to recognize certain common combinations, and fall back to NotStrict -- in the event there's an exotic combination. toBang (FieldStrictness UnspecifiedUnpackedness Strict) = IsStrict toBang (FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness) = NotStrict toBang (FieldStrictness Unpack Strict) = Unpacked toBang FieldStrictness{} = NotStrict #endif ------------------------------------------------------------------------------- -- Compat from base-4.9 ------------------------------------------------------------------------------- isSymbolChar :: Char -> Bool isSymbolChar c = not (isPuncChar c) && case generalCategory c of MathSymbol -> True CurrencySymbol -> True ModifierSymbol -> True OtherSymbol -> True DashPunctuation -> True OtherPunctuation -> c `notElem` "'\"" ConnectorPunctuation -> c /= '_' _ -> False isPuncChar :: Char -> Bool isPuncChar c = c `elem` ",;()[]{}`" ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- -- By manually generating these names we avoid needing to use the -- TemplateHaskell language extension when compiling this library. -- This allows the library to be used in stage1 cross-compilers. rsPackageKey :: String #ifdef CURRENT_PACKAGE_KEY rsPackageKey = CURRENT_PACKAGE_KEY #else rsPackageKey = "recursion-schemes-" ++ showVersion version #endif mkRsName_tc :: String -> String -> Name mkRsName_tc = mkNameG_tc rsPackageKey mkRsName_v :: String -> String -> Name mkRsName_v = mkNameG_v rsPackageKey baseTypeName :: Name baseTypeName = mkRsName_tc "Data.Functor.Foldable" "Base" recursiveTypeName :: Name recursiveTypeName = mkRsName_tc "Data.Functor.Foldable" "Recursive" corecursiveTypeName :: Name corecursiveTypeName = mkRsName_tc "Data.Functor.Foldable" "Corecursive" projectValName :: Name projectValName = mkRsName_v "Data.Functor.Foldable" "project" embedValName :: Name embedValName = mkRsName_v "Data.Functor.Foldable" "embed" functorTypeName :: Name functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" foldableTypeName :: Name foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" traversableTypeName :: Name traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"