recursion-schemes-5.0.2/0000755000000000000000000000000013124272644013347 5ustar0000000000000000recursion-schemes-5.0.2/CHANGELOG.markdown0000644000000000000000000000222413124272644016402 0ustar0000000000000000## 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.0.2/README.markdown0000644000000000000000000000113513124272644016050 0ustar0000000000000000recursion-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) This package includes code for functional programming with bananas, envelopes, lenses, barbed wire and all that. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett recursion-schemes-5.0.2/Setup.lhs0000644000000000000000000000016513124272644015161 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain recursion-schemes-5.0.2/recursion-schemes.cabal0000644000000000000000000000424013124272644017771 0ustar0000000000000000name: recursion-schemes category: Control, Recursion version: 5.0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett 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: Generalized bananas, lenses and barbed wire description: Recursion operators, see "Generalized bananas, lenses and barbed wire" by Erik Meijer, Maarten Fokkinga and Ross Paterson. 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.1 build-type: Simple extra-source-files: .travis.yml CHANGELOG.markdown .gitignore README.markdown 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 extensions: CPP other-extensions: TypeFamilies Rank2Types FlexibleContexts FlexibleInstances GADTs StandaloneDeriving UndecidableInstances build-depends: base >= 4 && < 5, bifunctors >= 4 && < 6, comonad >= 4 && < 6, free >= 4 && < 5, semigroups >= 0.8.3.1 && < 1, transformers >= 0.2 && < 1, transformers-compat >= 0.3 && < 1 if impl(ghc < 7.5) build-depends: ghc-prim if impl(ghc < 7.10) build-depends: nats exposed-modules: Data.Functor.Base Data.Functor.Foldable if flag(template-haskell) build-depends: template-haskell >= 2.5.0.0 && < 2.13, base-orphans >= 0.5.4 && <0.7 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 >= 2.5.0.0 && < 2.13, transformers >= 0.2 && < 1 recursion-schemes-5.0.2/.travis.yml0000644000000000000000000000712313124272644015463 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.16 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}} - env: CABALVER=1.16 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.2 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} - env: CABALVER=2.0 GHCVER=8.2.1 compiler: ": #GHC 8.2.1" addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}} before_install: - unset CC - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests --enable-benchmarks; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # 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: - if [ -f configure.ac ]; then autoreconf -i; fi - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests/benchmarks) - cabal test - cabal check - cabal sdist # tests that a source-distribution can be generated # Check that the resulting source distribution can be built & installed. # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") # EOF recursion-schemes-5.0.2/.gitignore0000644000000000000000000000027013124272644015336 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 recursion-schemes-5.0.2/LICENSE0000644000000000000000000000236413124272644014361 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.0.2/Data/0000755000000000000000000000000013124272644014220 5ustar0000000000000000recursion-schemes-5.0.2/Data/Functor/0000755000000000000000000000000013124272644015640 5ustar0000000000000000recursion-schemes-5.0.2/Data/Functor/Foldable.hs0000644000000000000000000005331613124272644017714 0ustar0000000000000000{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-} -- explicit dictionary higher-kind instances are defined in -- - base-4.9 -- - transformers >= 0.5 -- - transformes-compat >= 0.5 when transformers aren't 0.4 #define EXPLICIT_DICT_FUNCTOR_CLASSES (MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) || (MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0))) #define HAS_GENERIC (__GLASGOW_HASKELL__ >= 702) #define HAS_GENERIC1 (__GLASGOW_HASKELL__ >= 706) -- Polymorphic typeable #define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0) #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE ConstrainedClassMethods #-} #endif #if HAS_GENERIC {-# LANGUAGE DeriveGeneric #-} #endif #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Functor.Foldable ( -- * Base functors for fixed points Base , ListF(..) -- * Fixed points , Fix(..), unfix , Mu(..) , Nu(..) -- * Folding , Recursive(..) -- ** Combinators , gapo , gcata , zygo , gzygo , histo , ghisto , futu , 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 , refix -- * Common names , fold, gfold , unfold, gunfold , refold, grefold -- * Mendler-style , mcata , mhisto -- * Elgot (co)algebras , elgot , coelgot -- * Zygohistomorphic prepromorphisms , zygoHistoPrepro ) 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) #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(..)) type family Base t :: * -> * class Functor (Base t) => Recursive t where project :: t -> Base t t 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 . cata (embed . 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 . cata (embed . 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 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 (ana (e . project) . 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 (ana (e . project) . 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 ) #if EXPLICIT_DICT_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 distFutu :: Functor f => Free f (f a) -> f (Free f a) distFutu = distGFutu id distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> Free h (f a) -> f (Free h a) distGFutu _ (Pure fa) = Pure <$> fa distGFutu k (Free as) = Free <$> k (distGFutu k <$> as) ------------------------------------------------------------------------------- -- 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 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 -- | 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 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, Functor h) => (forall b. Base t (h b) -> h (Base t b)) -> (Base t (Cofree h a) -> a) -> t -> a ghisto g = gcata (distGHisto g) distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a) distHisto = distGHisto id distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (Cofree h a) -> Cofree h (f a) distGHisto k = Cofree.unfold (\as -> (extract <$> as, k (Cofree.unwrap <$> as))) 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) => (forall c. f (w c) -> w (f c)) -> (forall c. m (f c) -> f (m c)) -> (f (Cofree w b) -> b) -> (a -> f (Free 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 ------------------------------------------------------------------------------- -- Not exposed anywhere ------------------------------------------------------------------------------- -- | Read a list (using square brackets and commas), given a function -- for reading elements. _readListWith :: ReadS a -> ReadS [a] _readListWith rp = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) where readl s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] readl' s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] recursion-schemes-5.0.2/Data/Functor/Base.hs0000644000000000000000000000663413124272644017057 0ustar0000000000000000{-# LANGUAGE CPP #-} #define EXPLICIT_DICT_FUNCTOR_CLASSES (MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) || (MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0))) #define HAS_GENERIC (__GLASGOW_HASKELL__ >= 702) #define HAS_GENERIC1 (__GLASGOW_HASKELL__ >= 706) #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(..) #if EXPLICIT_DICT_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 ) #if EXPLICIT_DICT_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.0.2/Data/Functor/Foldable/0000755000000000000000000000000013124272644017350 5ustar0000000000000000recursion-schemes-5.0.2/Data/Functor/Foldable/TH.hs0000644000000000000000000003271613124272644020230 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module Data.Functor.Foldable.TH ( makeBaseFunctor , makeBaseFunctorWith , BaseRules , baseRules , baseRulesType , baseRulesCon , baseRulesField ) where import Control.Applicative as A import Data.Traversable as T import Data.Bifunctor (first) import Data.Functor.Identity import Language.Haskell.TH 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 = reify name >>= f where f (TyConI dec) = makePrimForDec rules dec f _ = fail "makeBaseFunctor: Expected type constructor name" -- | 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 makePrimForDec :: BaseRules -> Dec -> DecsQ makePrimForDec rules dec = case dec of #if MIN_VERSION_template_haskell(2,11,0) DataD _ tyName vars _ cons _ -> makePrimForDec' rules False tyName vars cons NewtypeD _ tyName vars _ con _ -> makePrimForDec' rules True tyName vars [con] #else DataD _ tyName vars cons _ -> makePrimForDec' rules False tyName vars cons NewtypeD _ tyName vars con _ -> makePrimForDec' rules True tyName vars [con] #endif _ -> fail "makeFieldOptics: Expected data type-constructor" makePrimForDec' :: BaseRules -> Bool -> Name -> [TyVarBndr] -> [Con] -> DecsQ makePrimForDec' 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] let fieldCons = map normalizeConstructor cons let consF = 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 #if MIN_VERSION_template_haskell(2,9,0) let baseDec = TySynInstD baseTypeName (TySynEqn [s] $ conAppsT tyNameF vars') #else let baseDec = TySynInstD baseTypeName [s] $ conAppsT tyNameF vars' #endif -- instance Recursive args <- (traverse . traverse . traverse) (\_ -> newName "x") fieldCons let projDec = FunD projectValName (mkMorphism id (_baseRulesCon rules) args) #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 let embedDec = FunD embedValName (mkMorphism (_baseRulesCon rules) id args) #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 pure [dataDec, baseDec, recursiveDec, corecursiveDec] -- | makes clauses to rename constructors mkMorphism :: (Name -> Name) -> (Name -> Name) -> [(Name, [Name])] -> [Clause] mkMorphism nFrom nTo args = flip map args $ \(n, fs) -> Clause [ConP (nFrom n) (map VarP fs)] -- patterns (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body [] -- where dec -- | Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal -- constructors. normalizeConstructor :: Con -> (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type normalizeConstructor (RecC n xs) = (n, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs]) normalizeConstructor (NormalC n xs) = (n, [ (Nothing, ty) | (_,ty) <- xs]) normalizeConstructor (InfixC (_,ty1) n (_,ty2)) = (n, [ (Nothing, ty1), (Nothing, ty2) ]) normalizeConstructor (ForallC _ _ con) = (fmap . fmap . first) (const Nothing) (normalizeConstructor con) #if MIN_VERSION_template_haskell(2,11,0) normalizeConstructor (GadtC ns xs _) = (head ns, [ (Nothing, ty) | (_,ty) <- xs]) normalizeConstructor (RecGadtC ns xs _) = (head ns, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs]) #endif ------------------------------------------------------------------------------- -- Traversals ------------------------------------------------------------------------------- conNameTraversal :: Applicative f => (Name -> f Name) -> Con -> f Con conNameTraversal f (NormalC n xs) = NormalC <$> f n <*> A.pure xs conNameTraversal f (RecC n xs) = RecC <$> f n <*> pure xs conNameTraversal f (InfixC l n r) = InfixC l <$> f n <*> pure r conNameTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conNameTraversal f con #if MIN_VERSION_template_haskell(2,11,0) conNameTraversal f (GadtC ns xs t) = GadtC <$> T.traverse f ns <*> pure xs <*> pure t conNameTraversal f (RecGadtC ns xs t) = RecGadtC <$> traverse f ns <*> pure xs <*> pure t #endif conFieldNameTraversal :: Applicative f => (Name -> f Name) -> Con -> f Con conFieldNameTraversal f (RecC n xs) = RecC n <$> (traverse . tripleFst) f xs conFieldNameTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conFieldNameTraversal f con #if MIN_VERSION_template_haskell(2,11,0) conFieldNameTraversal f (RecGadtC ns xs t) = RecGadtC ns <$> (traverse . tripleFst) f xs <*> pure t #endif conFieldNameTraversal _ x = pure x conTypeTraversal :: Applicative f => (Type -> f Type) -> Con -> f Con conTypeTraversal f (NormalC n xs) = NormalC n <$> (traverse . pairSnd) f xs conTypeTraversal f (RecC n xs) = RecC n <$> (traverse . tripleTrd) f xs conTypeTraversal f (InfixC l n r) = InfixC <$> pairSnd f l <*> pure n <*> pairSnd f r conTypeTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conTypeTraversal f con #if MIN_VERSION_template_haskell(2,11,0) conTypeTraversal f (GadtC ns xs t) = GadtC ns <$> (traverse . pairSnd) f xs <*> pure t conTypeTraversal f (RecGadtC ns xs t) = RecGadtC ns <$> (traverse . tripleTrd) f xs <*> pure t #endif conNameMap :: (Name -> Name) -> Con -> Con conNameMap f = runIdentity . conNameTraversal (Identity . f) conFieldNameMap :: (Name -> Name) -> Con -> Con conFieldNameMap f = runIdentity . conFieldNameTraversal (Identity . f) conTypeMap :: (Type -> Type) -> Con -> Con conTypeMap f = runIdentity . conTypeTraversal (Identity . f) ------------------------------------------------------------------------------- -- Monomorphic tuple lenses ------------------------------------------------------------------------------- type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s pairSnd :: Lens' (a, b) b pairSnd f (a, b) = (,) a <$> f b tripleTrd :: Lens' (a, b, c) c tripleTrd f (a,b,c) = (,,) a b <$> f c tripleFst :: Lens' (a, b, c) a tripleFst f (a,b,c) = (\a' -> (a', b, c)) <$> f a ------------------------------------------------------------------------------- -- Type mangling ------------------------------------------------------------------------------- -- | Extraty type variables typeVars :: [TyVarBndr] -> [Name] typeVars = map varBindName varBindName :: TyVarBndr -> Name varBindName (PlainTV n) = n varBindName (KindedTV n _) = n -- | 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 ------------------------------------------------------------------------------- -- 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" recursion-schemes-5.0.2/examples/0000755000000000000000000000000013124272644015165 5ustar0000000000000000recursion-schemes-5.0.2/examples/Expr.hs0000644000000000000000000000365213124272644016445 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Main where import Data.Functor.Foldable import Data.Functor.Foldable.TH import Language.Haskell.TH 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 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 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 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) }