recursion-schemes-5/0000755000000000000000000000000012766341613013055 5ustar0000000000000000recursion-schemes-5/.gitignore0000644000000000000000000000027012766341613015044 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/.travis.yml0000644000000000000000000000667212766341613015201 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.1 compiler: ": #GHC 8.0.1b" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.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 --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/CHANGELOG.markdown0000644000000000000000000000155512766341613016116 0ustar0000000000000000## 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/LICENSE0000644000000000000000000000236412766341613014067 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/README.markdown0000644000000000000000000000113512766341613015556 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/recursion-schemes.cabal0000644000000000000000000000254412766341613017504 0ustar0000000000000000name: recursion-schemes category: Control, Recursion version: 5 license: BSD3 cabal-version: >= 1.6 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: Generalized bananas, lenses and barbed wire tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.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 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, transformers >= 0.2 && < 1, transformers-compat >= 0.3 && < 1 if impl(ghc < 7.5) build-depends: ghc-prim exposed-modules: Data.Functor.Foldable ghc-options: -Wall recursion-schemes-5/Setup.lhs0000644000000000000000000000016512766341613014667 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain recursion-schemes-5/Data/0000755000000000000000000000000012766341613013726 5ustar0000000000000000recursion-schemes-5/Data/Functor/0000755000000000000000000000000012766341613015346 5ustar0000000000000000recursion-schemes-5/Data/Functor/Foldable.hs0000644000000000000000000004456512766341613017430 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.Monad (liftM, join) import Control.Monad.Free (Free(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Data.Functor.Identity import Control.Arrow import Data.Function (on) import Data.Functor.Classes 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 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 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 -> [] -- | 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 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]