recursion-schemes 3.0.0.2 → 5.2.3
raw patch · 14 files changed
Files
- .gitignore +29/−0
- .travis.yml +0/−1
- CHANGELOG.markdown +111/−0
- Data/Functor/Foldable.hs +0/−444
- LICENSE +1/−5
- README.markdown +167/−0
- Setup.lhs +0/−7
- docs/flowchart.svg +458/−0
- docs/github-compression.png binary
- examples/Expr.hs +124/−0
- recursion-schemes.cabal +58/−21
- src/Data/Functor/Base.hs +196/−0
- src/Data/Functor/Foldable.hs +1043/−0
- src/Data/Functor/Foldable/TH.hs +495/−0
+ .gitignore view
@@ -0,0 +1,29 @@+dist/+dist-newstyle/+.stack-work/+.hsenv/+doc/+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.*
− .travis.yml
@@ -1,1 +0,0 @@-language: haskell
+ CHANGELOG.markdown view
@@ -0,0 +1,111 @@+## 5.2.3 [2024-06-12]++* Support GHC-9.10.+* Drop support for GHC-7.10 and earlier.++## 5.2.2.5 [2023-10-14]++* Support GHC-9.6 and GHC-9.8+* Support `th-abstraction-0.6.0.0` or later.++## 5.2.2.4 [2023-02-27]++* Support `th-abstraction-0.5.0.0` or later.++## 5.2.2.3++* Support GHC-9.4+* Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/18320, which was+ preventing code calling makeBaseFunctor from being profiled.++## 5.2.2.2++* Support GHC-9.0 and GHC-9.2++## 5.2.2.1++* Fix build issue regarding `Setup.hs`. See #120.++## 5.2.2+* More Mendler-style recursion-schemes: `mpara`, `mzygo`, `mana`, `mapo`, and+ `mfutu`.+* `makeBaseFunctor` no longer generates warnings when combined with+ DerivingStrategies.++## 5.2.1 [2020-10-04]+* Allow building with `template-haskell-2.17.0.0` (GHC 9.0).++## 5.2++* Add instances for `Tree` (from `containers`)+* Add some haddocks and basic examples+* Generalize the type of `makeBaseFunctor(With)`, such that+ it can take also `Dec`. This way you may supply context for `Recursive`+ and `Corecursive` instances.+* Depend on `data-fix` package for fixed point types.++## 5.1.3 [2019-04-26]+* Support `th-abstraction-0.3.0.0` or later.++## 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`
− Data/Functor/Foldable.hs
@@ -1,444 +0,0 @@-{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : Data.Functor.Foldable--- Copyright : (C) 2008 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable--- ------------------------------------------------------------------------------module Data.Functor.Foldable- ( - -- * Base functors for fixed points- Base- -- * Fixed points- , Fix(..)- , Mu(..)- , Nu(..)- , Prim(..)- -- * Folding- , Foldable(..)- -- ** Combinators- , gcata- , zygo- , gzygo- , histo- , ghisto- , futu- -- ** Distributive laws- , distCata- , distPara- , distParaT- , distZygo- , distZygoT- , distHisto- , distGHisto- , distFutu- , distGFutu- -- * Unfolding- , Unfoldable(..)- -- ** Combinators- , gana- -- ** Distributive laws- , distAna- , distApo- , distGApo- -- * 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-import Data.Functor.Identity-import Control.Arrow-import Data.Function (on)-import Text.Read-#ifdef __GLASGOW_HASKELL__-import Data.Data hiding (gunfold)-import qualified Data.Data as Data-#endif--type family Base t :: * -> *--data family Prim t :: * -> *--- type instance Base (Maybe a) = Const (Maybe a) --- type instance Base (Either a b) = Const (Either a b)--class Functor (Base t) => Foldable 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 :: Unfoldable t => (Base t (t, a) -> a) -> t -> a- para t = zygo embed t-- gpara :: (Unfoldable 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 - :: Unfoldable 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 - :: (Unfoldable 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 :: Unfoldable t => Base t (t, a) -> (t, Base t a)-distPara = distZygo embed--distParaT :: (Unfoldable 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) => Unfoldable 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 :: Foldable t => (a -> Base t (Either t a)) -> a -> t- apo = gapo project-- -- | Fokkinga's postpromorphism- postpro - :: Foldable 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 - :: (Foldable 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 :: Foldable t => (Base t a -> a) -> t -> a-fold = cata--unfold :: Unfoldable t => (a -> Base t a) -> a -> t-unfold = ana--refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b-refold = hylo--data instance Prim [a] b = Cons a b | Nil deriving (Eq,Ord,Show,Read)-instance Functor (Prim [a]) where- fmap f (Cons a b) = Cons a (f b)- fmap _ Nil = Nil--type instance Base [a] = Prim [a] -instance Foldable [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 Unfoldable [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 Foldable (Maybe a) where project = Const -instance Unfoldable (Maybe a) where embed = getConst ---- | Example boring stub for non-recursive data types-type instance Base (Either a b) = Const (Either a b)-instance Foldable (Either a b) where project = Const -instance Unfoldable (Either a b) where embed = getConst ---- | A generalized catamorphism-gfold, gcata- :: (Foldable 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- :: (Unfoldable 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 :: Unfoldable 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)--newtype Fix f = Fix (f (Fix f))--unfix :: Fix f -> f (Fix f)-unfix (Fix f) = f--deriving instance Eq (f (Fix f)) => Eq (Fix f)-deriving instance Ord (f (Fix f)) => Ord (Fix f)-deriving instance Show (f (Fix f)) => Show (Fix f)-deriving instance Read (f (Fix f)) => Read (Fix f)--#ifdef __GLASGOW_HASKELL__-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--type instance Base (Fix f) = f-instance Functor f => Foldable (Fix f) where- project (Fix a) = a-instance Functor f => Unfoldable (Fix f) where- embed = Fix--refix :: (Foldable s, Unfoldable t, Base s ~ Base t) => s -> t-refix = cata embed--toFix :: Foldable t => t -> Fix (Base t)-toFix = refix--fromFix :: Unfoldable t => Fix (Base t) -> t-fromFix = refix---- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed'-lambek :: (Foldable t, Unfoldable 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 :: (Foldable t, Unfoldable 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 => Foldable (Mu f) where- project = lambek- cata f (Mu g) = g f-instance Functor f => Unfoldable (Mu f) where- embed m = Mu (\f -> f (fmap (fold f) m))--instance (Functor f, Eq (f (Fix f)), Eq (Fix f)) => Eq (Mu f) where- (==) = (==) `on` toFix--instance (Functor f, Ord (f (Fix f)), Ord (Fix f)) => Ord (Mu f) where- compare = compare `on` toFix--instance (Functor f, Show (f (Fix f)), Show (Fix f)) => Show (Mu f) where- showsPrec d f = showParen (d > 10) $- showString "fromFix " . showsPrec 11 (toFix f)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f (Fix f)), Read (Fix 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 => Unfoldable (Nu f) where- embed = colambek- ana = Nu -instance Functor f => Foldable (Nu f) where- project (Nu f a) = Nu f <$> f a--instance (Functor f, Eq (f (Fix f)), Eq (Fix f)) => Eq (Nu f) where- (==) = (==) `on` toFix--instance (Functor f, Ord (f (Fix f)), Ord (Fix f)) => Ord (Nu f) where- compare = compare `on` toFix--instance (Functor f, Show (f (Fix f)), Show (Fix f)) => Show (Nu f) where- showsPrec d f = showParen (d > 10) $- showString "fromFix " . showsPrec 11 (toFix f)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read (f (Fix f)), Read (Fix f)) => Read (Nu f) where- readPrec = parens $ prec 10 $ do- Ident "fromFix" <- lexP- fromFix <$> step readPrec-#endif--zygo :: Foldable 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 - :: (Foldable 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 :: Unfoldable t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t-gapo g = gunfold (distGApo g)--distApo :: Foldable 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)---- | Course-of-value iteration-histo :: Foldable t => (Base t (Cofree (Base t) a) -> a) -> t -> a-histo = gcata distHisto--ghisto :: (Foldable 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)))---- TODO: futu & chrono, these require Free monads --- TODO: distGApoT, requires EitherT---- | 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: <http://comonad.com/reader/2008/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 <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>-zygoHistoPrepro- :: (Unfoldable t, Foldable 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2011 Edward Kmett+Copyright 2011-2015 Edward Kmett All rights reserved. @@ -12,10 +12,6 @@ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ README.markdown view
@@ -0,0 +1,167 @@+# recursion-schemes++[](https://hackage.haskell.org/package/recursion-schemes) [](https://github.com/ekmett/recursion-schemes/actions?query=workflow%3AHaskell-CI)++This package represents common recursion patterns as higher-order functions.++## A familiar example++Here are two recursive functions.++```haskell+sum :: [Int] -> Int+sum [] = 0+sum (x:xs) = x + sum xs++product :: [Int] -> Int+product [] = 1+product (x:xs) = x * product xs+```++These functions are very similar. In both cases, the empty list is the base case. In the cons case, each makes a recursive call on the tail of the list. Then, the head of the list is combined with the result using a binary function.++We can abstract over those similarities using a higher-order function, [`foldr`](https://hackage.haskell.org/package/base/docs/Data-List.html#v:foldr):++```haskell+sum = foldr (+) 0+product = foldr (*) 1+```++## Other recursive types++`foldr` works great for lists. The higher-order functions provided by this library help with other recursive datatypes. Here are two recursive functions on [`Tree`s](https://hackage.haskell.org/package/containers/docs/Data-Tree.html#t:Tree):++```haskell+depth :: Tree a -> Int+depth (Node _ subTrees) = 1 + maximum subTrees++size :: Tree a -> Int+size (Node _ subTrees) = 1 + sum subTrees+```++It is not possible to use `foldr` to simplify `depth`. Conceptually, `foldr` is flattening all the elements of the tree into a list before combining them with the binary function. This does not work for `depth` because it needs to examine the structure of the tree, which `foldr` flattened away.++We can instead use one of the higher-order functions provided by this library, [`cata`](https://hackage.haskell.org/package/recursion-schemes/docs/Data-Functor-Foldable.html#v:cata).++```haskell+import Data.Functor.Base (TreeF(..))+import Data.Functor.Foldable++-- data Tree a = Node a [Tree a]+-- data TreeF a r = NodeF a [r ]++depth :: Tree a -> Int+depth = cata go+ where+ go :: TreeF a Int -> Int+ go (NodeF _ subDepths) = 1 + maximum subDepths++size :: Tree a -> Int+size = cata go+ where+ go :: TreeF a Int -> Int+ go (NodeF _ subSizes) = 1 + sum subSizes+```++In this example, the code is a bit longer, but it is correct. Did you spot the mistake in the version which does not use `cata`? We forgot a call to `fmap`:++```haskell+depth :: Tree a -> Int+depth (Node _ subTrees) = 1 + maximum (fmap depth subTrees)++size :: Tree a -> Int+size (Node _ subTrees) = 1 + sum (fmap size subTrees)+```++`cata` automatically adds this call to `fmap`. This is why `subDepths` contains a list of already-computed depths, not a list of sub-trees. In general, each recursive position is replaced by the result of a recursive call. These results have type `Int`, not type `Tree`, so we need a helper datatype `TreeF` to collect these results.++When you think about computing the depth, you probably think "it's 1 plus the maximum of the sub-depths". With `cata`, this is exactly what we write. By contrast, without `cata`, we need to describe both the "how" and the "what" in our implementation. The "how" is about recurring over the sub-trees (using `fmap depth`), while the "what" is about adding 1 to the maximum of the sub-trees. `cata` takes care of the recursion, so you can focus solely on the "what".++A **recursion-scheme** is a function like `cata` which implements a common recursion pattern. It is a higher-order recursive function which takes a non-recursive function as an argument. That non-recursive function describes the part which is unique to your calculation: the "what".++## Types with many constructors++Let's look at a more complex example. Here is a small lambda-calculus and a function to compute the [free variables](https://en.wikipedia.org/wiki/Lambda_calculus#Free_variables) of an expression:++```haskell+import Data.Set (Set)+import qualified Data.Set as Set++data Expr+ = Var String+ | Lam String Expr+ | App Expr Expr+ | Constant Int+ | Add Expr Expr+ | Sub Expr Expr+ | Mul Expr Expr+ | Div Expr Expr+ | ...++freeVars :: Expr -> Set String+freeVars (Var name) = Set.singleton name+freeVars (Lam name body) = Set.difference (freeVars body) (Set.singleton name)+freeVars (App e1 e2) = Set.union (freeVars e1) (freeVars e2)+freeVars (Constant _) = Set.empty+freeVars (Add e1 e2) = Set.union (freeVars e1) (freeVars e2)+freeVars (Sub e1 e2) = Set.union (freeVars e1) (freeVars e2)+freeVars (Mul e1 e2) = Set.union (freeVars e1) (freeVars e2)+freeVars (Div e1 e2) = Set.union (freeVars e1) (freeVars e2)+freeVars ...+```++As you can see, we had to repeat the `Set.union (freeVars e1) (freeVars e2)` line over and over. With recursion-schemes, this code becomes much shorter:++```haskell+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell, TypeFamilies #-}+import Data.Functor.Foldable.TH (makeBaseFunctor)++makeBaseFunctor ''Expr++freeVars :: Expr -> Set String+freeVars = cata go+ where+ go :: ExprF (Set String) -> Set String+ go (VarF name) = Set.singleton name+ go (LamF name bodyNames) = Set.difference bodyNames (Set.singleton name)+ go fNames = foldr Set.union Set.empty fNames+```++The `makeBaseFunctor` line uses Template Haskell to generate our `ExprF` datatype, a single layer of the `Expr` datatype. `makeBaseFunctor` also generates instances which are useful when using recursion-schemes. For example, we make use of the `Foldable ExprF` instance on the last line of `go`. This `Foldable` instance exists because `ExprF` has kind `* -> *`, while `Expr` has kind `*`.++## Other recursion-schemes++All of our examples so far have used `cata`. There are many more recursion-schemes. Here is an example which follows a different recursive structure:++```haskell+-- |+-- >>> halves 256+-- [256,128,64,32,16,8,4,2,1]+halves :: Int -> [Int]+halves 0 = []+halves n = n : halves (n `div` 2)+```++That recursive structure is captured by the [`ana`](https://hackage.haskell.org/package/recursion-schemes/docs/Data-Functor-Foldable.html#v:ana) recursion-scheme:++```haskell+halves :: Int -> [Int]+halves = ana go+ where+ go :: Int -> ListF Int Int+ go 0 = Nil+ go n = Cons n (n `div` 2)+```++The [Data.Functor.Foldable](https://hackage.haskell.org/package/recursion-schemes/docs/Data-Functor-Foldable.html) module provides many more.++## Flowchart for choosing a recursion-scheme+++++In addition to the choices described by the flowchart, you can always choose to use a refold.++## Contributing++Contributions and [bug reports](https://github.com/ekmett/recursion-schemes/issues/new) are welcome!
− Setup.lhs
@@ -1,7 +0,0 @@-#!/usr/bin/runhaskell-> module Main (main) where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain
+ docs/flowchart.svg view
@@ -0,0 +1,458 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 2.43.0 (0)+ -->+<!-- Title: %3 Pages: 1 -->+<svg width="1672pt" height="1063pt"+ viewBox="0.00 0.00 1672.12 1063.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 1059)">+<title>%3</title>+<polygon fill="white" stroke="transparent" points="-4,4 -4,-1059 1668.12,-1059 1668.12,4 -4,4"/>+<g id="clust1" class="cluster">+<title>cluster_beginner</title>+<polygon fill="none" stroke="transparent" points="575,-557 575,-863 1169,-863 1169,-557 575,-557"/>+</g>+<g id="clust2" class="cluster">+<title>cluster_expert</title>+<polygon fill="none" stroke="transparent" points="8,-557 8,-716 567,-716 567,-557 8,-557"/>+</g>+<!-- decision1 -->+<g id="node1" class="node">+<title>decision1</title>+<polygon fill="none" stroke="black" points="723,-855 583,-817 723,-779 863,-817 723,-855"/>+<text text-anchor="middle" x="723" y="-820.8" font-family="Times,serif" font-size="14.00">Is your input</text>+<text text-anchor="middle" x="723" y="-805.8" font-family="Times,serif" font-size="14.00">a recursive type?</text>+</g>+<!-- decision1_1 -->+<g id="node2" class="node">+<title>decision1_1</title>+<polygon fill="none" stroke="black" points="1021,-728 881,-690 1021,-652 1161,-690 1021,-728"/>+<text text-anchor="middle" x="1021" y="-693.8" font-family="Times,serif" font-size="14.00">Is your output</text>+<text text-anchor="middle" x="1021" y="-678.8" font-family="Times,serif" font-size="14.00">a recursive type?</text>+</g>+<!-- decision1->decision1_1 -->+<g id="edge10" class="edge">+<title>decision1->decision1_1</title>+<path fill="none" stroke="black" d="M776.62,-793.51C827.52,-772.16 904.04,-740.06 957.87,-717.48"/>+<polygon fill="black" stroke="black" points="959.44,-720.62 967.31,-713.52 956.73,-714.16 959.44,-720.62"/>+<text text-anchor="middle" x="901.5" y="-749.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- decision1_2 -->+<g id="node3" class="node">+<title>decision1_2</title>+<polygon fill="none" stroke="black" points="723,-728 583,-690 723,-652 863,-690 723,-728"/>+<text text-anchor="middle" x="723" y="-693.8" font-family="Times,serif" font-size="14.00">Is your output</text>+<text text-anchor="middle" x="723" y="-678.8" font-family="Times,serif" font-size="14.00">a recursive type?</text>+</g>+<!-- decision1->decision1_2 -->+<g id="edge11" class="edge">+<title>decision1->decision1_2</title>+<path fill="none" stroke="black" d="M723,-778.83C723,-766.1 723,-751.68 723,-738.26"/>+<polygon fill="black" stroke="black" points="726.5,-738.24 723,-728.24 719.5,-738.24 726.5,-738.24"/>+<text text-anchor="middle" x="732" y="-749.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- decision1_1_no -->+<g id="node6" class="node">+<title>decision1_1_no</title>+<ellipse fill="none" stroke="transparent" cx="1002" cy="-583" rx="27" ry="18"/>+<text text-anchor="middle" x="1002" y="-579.3" font-family="Times,serif" font-size="14.00">No</text>+</g>+<!-- decision1_1->decision1_1_no -->+<g id="edge4" class="edge">+<title>decision1_1->decision1_1_no</title>+<path fill="none" stroke="black" d="M1014.57,-653.45C1011.36,-635.72 1007.63,-615.1 1005.07,-600.96"/>+</g>+<!-- choose_either -->+<g id="node7" class="node">+<title>choose_either</title>+<ellipse fill="none" stroke="black" cx="872" cy="-583" rx="65.79" ry="18"/>+<text text-anchor="middle" x="872" y="-579.3" font-family="Times,serif" font-size="14.00">I feel lucky!</text>+</g>+<!-- decision1_1->choose_either -->+<g id="edge12" class="edge">+<title>decision1_1->choose_either</title>+<path fill="none" stroke="black" d="M983.02,-662.23C958.24,-644.78 926.32,-622.28 903.07,-605.89"/>+<polygon fill="black" stroke="black" points="904.8,-602.83 894.61,-599.93 900.77,-608.56 904.8,-602.83"/>+<text text-anchor="middle" x="954.5" y="-622.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- decision1_2_yes -->+<g id="node4" class="node">+<title>decision1_2_yes</title>+<ellipse fill="none" stroke="transparent" cx="723" cy="-583" rx="27" ry="18"/>+<text text-anchor="middle" x="723" y="-579.3" font-family="Times,serif" font-size="14.00">Yes</text>+</g>+<!-- decision1_2->decision1_2_yes -->+<g id="edge5" class="edge">+<title>decision1_2->decision1_2_yes</title>+<path fill="none" stroke="black" d="M723,-651.98C723,-634.62 723,-614.78 723,-601.04"/>+</g>+<!-- decision1_2_no -->+<g id="node5" class="node">+<title>decision1_2_no</title>+<ellipse fill="none" stroke="transparent" cx="651" cy="-583" rx="27" ry="18"/>+<text text-anchor="middle" x="651" y="-579.3" font-family="Times,serif" font-size="14.00">No</text>+</g>+<!-- decision1_2->decision1_2_no -->+<g id="edge6" class="edge">+<title>decision1_2->decision1_2_no</title>+<path fill="none" stroke="black" d="M701.59,-657.78C688.49,-638.68 672.29,-615.05 661.81,-599.76"/>+</g>+<!-- start_unfolds -->+<g id="node9" class="node">+<title>start_unfolds</title>+<ellipse fill="none" stroke="black" cx="689" cy="-472" rx="79.09" ry="18"/>+<text text-anchor="middle" x="689" y="-468.3" font-family="Times,serif" font-size="14.00">Use an unfold!</text>+</g>+<!-- decision1_2_yes->start_unfolds -->+<g id="edge8" class="edge">+<title>decision1_2_yes->start_unfolds</title>+<path fill="none" stroke="black" d="M717.69,-564.97C712.26,-547.55 703.74,-520.24 697.39,-499.9"/>+<polygon fill="black" stroke="black" points="700.71,-498.78 694.39,-490.27 694.02,-500.86 700.71,-498.78"/>+</g>+<!-- start_refolds -->+<g id="node10" class="node">+<title>start_refolds</title>+<ellipse fill="none" stroke="black" cx="520" cy="-472" rx="71.49" ry="18"/>+<text text-anchor="middle" x="520" y="-468.3" font-family="Times,serif" font-size="14.00">Use a refold!</text>+</g>+<!-- decision1_2_no->start_refolds -->+<g id="edge9" class="edge">+<title>decision1_2_no->start_refolds</title>+<path fill="none" stroke="black" d="M634.67,-568.42C612.92,-550.31 574.11,-518.02 547.72,-496.07"/>+<polygon fill="black" stroke="black" points="549.89,-493.32 539.97,-489.61 545.41,-498.7 549.89,-493.32"/>+</g>+<!-- start_folds -->+<g id="node8" class="node">+<title>start_folds</title>+<ellipse fill="none" stroke="black" cx="937" cy="-472" rx="61.99" ry="18"/>+<text text-anchor="middle" x="937" y="-468.3" font-family="Times,serif" font-size="14.00">Use a fold!</text>+</g>+<!-- decision1_1_no->start_folds -->+<g id="edge7" class="edge">+<title>decision1_1_no->start_folds</title>+<path fill="none" stroke="black" d="M992.41,-565.92C981.83,-548.17 964.65,-519.37 952.23,-498.53"/>+<polygon fill="black" stroke="black" points="955.19,-496.66 947.06,-489.87 949.17,-500.25 955.19,-496.66"/>+</g>+<!-- choose_either->start_folds -->+<g id="edge19" class="edge">+<title>choose_either->start_folds</title>+<path fill="none" stroke="black" d="M882.16,-564.97C892.75,-547.21 909.47,-519.17 921.67,-498.71"/>+<polygon fill="black" stroke="black" points="924.8,-500.29 926.92,-489.91 918.79,-496.71 924.8,-500.29"/>+</g>+<!-- choose_either->start_unfolds -->+<g id="edge20" class="edge">+<title>choose_either->start_unfolds</title>+<path fill="none" stroke="black" d="M845.78,-566.38C813.98,-547.44 760.24,-515.43 724.69,-494.26"/>+<polygon fill="black" stroke="black" points="726.45,-491.23 716.07,-489.12 722.87,-497.25 726.45,-491.23"/>+</g>+<!-- choose_either->start_refolds -->+<!-- fold1 -->+<g id="node13" class="node">+<title>fold1</title>+<polygon fill="none" stroke="black" points="1018,-417 799,-379 1018,-341 1237,-379 1018,-417"/>+<text text-anchor="middle" x="1018" y="-382.8" font-family="Times,serif" font-size="14.00">Do you only combine results</text>+<text text-anchor="middle" x="1018" y="-367.8" font-family="Times,serif" font-size="14.00">from recursive calls?</text>+</g>+<!-- start_folds->fold1 -->+<g id="edge22" class="edge">+<title>start_folds->fold1</title>+<path fill="none" stroke="black" d="M951.86,-454.31C960.56,-444.54 971.94,-431.75 982.8,-419.55"/>+<polygon fill="black" stroke="black" points="985.43,-421.85 989.47,-412.06 980.2,-417.2 985.43,-421.85"/>+</g>+<!-- unfold1 -->+<g id="node17" class="node">+<title>unfold1</title>+<polygon fill="none" stroke="black" points="545,-417 309,-379 545,-341 781,-379 545,-417"/>+<text text-anchor="middle" x="545" y="-382.8" font-family="Times,serif" font-size="14.00">Do you only generate subtrees</text>+<text text-anchor="middle" x="545" y="-367.8" font-family="Times,serif" font-size="14.00">by making recursive calls?</text>+</g>+<!-- start_unfolds->unfold1 -->+<g id="edge31" class="edge">+<title>start_unfolds->unfold1</title>+<path fill="none" stroke="black" d="M663.59,-454.94C646.05,-443.86 622.06,-428.7 600.24,-414.91"/>+<polygon fill="black" stroke="black" points="602.01,-411.88 591.68,-409.5 598.27,-417.8 602.01,-411.88"/>+</g>+<!-- decision0 -->+<g id="node11" class="node">+<title>decision0</title>+<polygon fill="none" stroke="black" points="505,-982 267,-944 505,-906 743,-944 505,-982"/>+<text text-anchor="middle" x="505" y="-947.8" font-family="Times,serif" font-size="14.00">Do you know which shape your</text>+<text text-anchor="middle" x="505" y="-932.8" font-family="Times,serif" font-size="14.00">function's recursion will have?</text>+</g>+<!-- decision0->decision1 -->+<g id="edge2" class="edge">+<title>decision0->decision1</title>+<path fill="none" stroke="black" d="M555.56,-914.01C589.85,-894.35 635.1,-868.4 669.92,-848.44"/>+<polygon fill="black" stroke="black" points="672.05,-851.25 678.98,-843.24 668.57,-845.18 672.05,-851.25"/>+<text text-anchor="middle" x="636" y="-876.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- expert_decision1 -->+<g id="node12" class="node">+<title>expert_decision1</title>+<polygon fill="none" stroke="black" points="336,-708 196.08,-690 336,-672 475.92,-690 336,-708"/>+<text text-anchor="middle" x="336" y="-686.3" font-family="Times,serif" font-size="14.00">What is the shape?</text>+</g>+<!-- decision0->expert_decision1 -->+<g id="edge3" class="edge">+<title>decision0->expert_decision1</title>+<path fill="none" stroke="black" d="M482.56,-909.54C447.96,-857.95 382.43,-760.24 352.12,-715.04"/>+<polygon fill="black" stroke="black" points="355.03,-713.09 346.55,-706.73 349.21,-716.99 355.03,-713.09"/>+<text text-anchor="middle" x="462.5" y="-813.3" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- same_as_input_type -->+<g id="node29" class="node">+<title>same_as_input_type</title>+<ellipse fill="none" stroke="transparent" cx="458" cy="-583" rx="100.98" ry="18"/>+<text text-anchor="middle" x="458" y="-579.3" font-family="Times,serif" font-size="14.00">Same as input type</text>+</g>+<!-- expert_decision1->same_as_input_type -->+<g id="edge13" class="edge">+<title>expert_decision1->same_as_input_type</title>+<path fill="none" stroke="black" d="M353.22,-674.18C375.68,-654.85 414.89,-621.1 438.45,-600.83"/>+</g>+<!-- same_as_output_type -->+<g id="node30" class="node">+<title>same_as_output_type</title>+<ellipse fill="none" stroke="transparent" cx="233" cy="-583" rx="106.68" ry="18"/>+<text text-anchor="middle" x="233" y="-579.3" font-family="Times,serif" font-size="14.00">Same as output type</text>+</g>+<!-- expert_decision1->same_as_output_type -->+<g id="edge15" class="edge">+<title>expert_decision1->same_as_output_type</title>+<path fill="none" stroke="black" d="M320.8,-673.51C301.78,-654.11 269.3,-621 249.63,-600.95"/>+</g>+<!-- neither -->+<g id="node31" class="node">+<title>neither</title>+<ellipse fill="none" stroke="transparent" cx="62" cy="-583" rx="46.29" ry="18"/>+<text text-anchor="middle" x="62" y="-579.3" font-family="Times,serif" font-size="14.00">Neither</text>+</g>+<!-- expert_decision1->neither -->+<g id="edge17" class="edge">+<title>expert_decision1->neither</title>+<path fill="none" stroke="black" d="M302.68,-676.23C249.48,-655.84 146.06,-616.21 93.82,-596.19"/>+</g>+<!-- fold2 -->+<g id="node14" class="node">+<title>fold2</title>+<polygon fill="none" stroke="black" points="973,-290 810,-252 973,-214 1136,-252 973,-290"/>+<text text-anchor="middle" x="973" y="-255.8" font-family="Times,serif" font-size="14.00">Only from</text>+<text text-anchor="middle" x="973" y="-240.8" font-family="Times,serif" font-size="14.00">immediate children?</text>+</g>+<!-- fold1->fold2 -->+<g id="edge23" class="edge">+<title>fold1->fold2</title>+<path fill="none" stroke="black" d="M1005.35,-342.85C1000.23,-328.63 994.26,-312.06 988.86,-297.05"/>+<polygon fill="black" stroke="black" points="992.08,-295.68 985.4,-287.46 985.5,-298.05 992.08,-295.68"/>+<text text-anchor="middle" x="1010.5" y="-311.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- fold3 -->+<g id="node15" class="node">+<title>fold3</title>+<polygon fill="none" stroke="black" points="1333,-290 1154,-252 1333,-214 1512,-252 1333,-290"/>+<text text-anchor="middle" x="1333" y="-255.8" font-family="Times,serif" font-size="14.00">Only that and examine</text>+<text text-anchor="middle" x="1333" y="-240.8" font-family="Times,serif" font-size="14.00">the original subtrees?</text>+</g>+<!-- fold1->fold3 -->+<g id="edge24" class="edge">+<title>fold1->fold3</title>+<path fill="none" stroke="black" d="M1082.89,-352.25C1135.3,-331.45 1208.94,-302.23 1262.74,-280.88"/>+<polygon fill="black" stroke="black" points="1264.2,-284.07 1272.21,-277.12 1261.62,-277.56 1264.2,-284.07"/>+<text text-anchor="middle" x="1203" y="-311.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- cata -->+<g id="node21" class="node">+<title>cata</title>+<ellipse fill="none" stroke="black" cx="875" cy="-125" rx="55.49" ry="18"/>+<text text-anchor="middle" x="875" y="-121.3" font-family="Times,serif" font-size="14.00">Use cata!</text>+</g>+<!-- fold2->cata -->+<g id="edge25" class="edge">+<title>fold2->cata</title>+<path fill="none" stroke="black" d="M948.27,-219.46C931.5,-198.07 909.66,-170.21 894.2,-150.49"/>+<polygon fill="black" stroke="black" points="896.92,-148.29 887.99,-142.57 891.41,-152.6 896.92,-148.29"/>+<text text-anchor="middle" x="941.5" y="-184.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- histo -->+<g id="node22" class="node">+<title>histo</title>+<ellipse fill="none" stroke="black" cx="1007" cy="-125" rx="58.49" ry="18"/>+<text text-anchor="middle" x="1007" y="-121.3" font-family="Times,serif" font-size="14.00">Use histo!</text>+</g>+<!-- fold2->histo -->+<g id="edge26" class="edge">+<title>fold2->histo</title>+<path fill="none" stroke="black" d="M982.47,-216.18C987.92,-196.16 994.65,-171.39 999.69,-152.88"/>+<polygon fill="black" stroke="black" points="1003.12,-153.62 1002.36,-143.05 996.36,-151.78 1003.12,-153.62"/>+<text text-anchor="middle" x="1001" y="-184.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- fold4 -->+<g id="node16" class="node">+<title>fold4</title>+<polygon fill="none" stroke="black" points="1298,-163 1152,-125 1298,-87 1444,-125 1298,-163"/>+<text text-anchor="middle" x="1298" y="-128.8" font-family="Times,serif" font-size="14.00">What do you do to</text>+<text text-anchor="middle" x="1298" y="-113.8" font-family="Times,serif" font-size="14.00">each subtree?</text>+</g>+<!-- fold3->fold4 -->+<g id="edge27" class="edge">+<title>fold3->fold4</title>+<path fill="none" stroke="black" d="M1323.16,-215.85C1319.25,-201.88 1314.7,-185.65 1310.56,-170.86"/>+<polygon fill="black" stroke="black" points="1313.84,-169.57 1307.77,-160.89 1307.09,-171.46 1313.84,-169.57"/>+<text text-anchor="middle" x="1329.5" y="-184.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- gcata -->+<g id="node20" class="node">+<title>gcata</title>+<ellipse fill="none" stroke="black" cx="1563" cy="-125" rx="101.23" ry="37.45"/>+<text text-anchor="middle" x="1563" y="-136.3" font-family="Times,serif" font-size="14.00">Write your own</text>+<text text-anchor="middle" x="1563" y="-121.3" font-family="Times,serif" font-size="14.00">recursion scheme</text>+<text text-anchor="middle" x="1563" y="-106.3" font-family="Times,serif" font-size="14.00">(using gcata)!</text>+</g>+<!-- fold3->gcata -->+<g id="edge28" class="edge">+<title>fold3->gcata</title>+<path fill="none" stroke="black" d="M1382.06,-224.34C1415.87,-205.96 1461.17,-181.34 1497.98,-161.34"/>+<polygon fill="black" stroke="black" points="1500.03,-164.21 1507.15,-156.36 1496.69,-158.06 1500.03,-164.21"/>+<text text-anchor="middle" x="1470" y="-184.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- zygo -->+<g id="node23" class="node">+<title>zygo</title>+<ellipse fill="none" stroke="black" cx="1232" cy="-18" rx="57.39" ry="18"/>+<text text-anchor="middle" x="1232" y="-14.3" font-family="Times,serif" font-size="14.00">Use zygo!</text>+</g>+<!-- fold4->zygo -->+<g id="edge29" class="edge">+<title>fold4->zygo</title>+<path fill="none" stroke="black" d="M1277.84,-91.93C1268.32,-76.79 1257.12,-58.96 1248.17,-44.73"/>+<polygon fill="black" stroke="black" points="1250.94,-42.56 1242.66,-35.95 1245.02,-46.28 1250.94,-42.56"/>+<text text-anchor="middle" x="1301" y="-57.8" font-family="Times,serif" font-size="14.00">Apply cata</text>+</g>+<!-- para -->+<g id="node24" class="node">+<title>para</title>+<ellipse fill="none" stroke="black" cx="1364" cy="-18" rx="56.59" ry="18"/>+<text text-anchor="middle" x="1364" y="-14.3" font-family="Times,serif" font-size="14.00">Use para!</text>+</g>+<!-- fold4->para -->+<g id="edge30" class="edge">+<title>fold4->para</title>+<path fill="none" stroke="black" d="M1324.61,-93.62C1330.73,-85.88 1336.93,-77.37 1342,-69 1346.42,-61.7 1350.45,-53.35 1353.82,-45.6"/>+<polygon fill="black" stroke="black" points="1357.12,-46.79 1357.72,-36.21 1350.65,-44.11 1357.12,-46.79"/>+<text text-anchor="middle" x="1404.5" y="-57.8" font-family="Times,serif" font-size="14.00">Something else</text>+</g>+<!-- unfold2 -->+<g id="node18" class="node">+<title>unfold2</title>+<polygon fill="none" stroke="black" points="183,-290 14,-252 183,-214 352,-252 183,-290"/>+<text text-anchor="middle" x="183" y="-255.8" font-family="Times,serif" font-size="14.00">Do you only generate</text>+<text text-anchor="middle" x="183" y="-240.8" font-family="Times,serif" font-size="14.00">1 layer at a time?</text>+</g>+<!-- unfold1->unfold2 -->+<g id="edge32" class="edge">+<title>unfold1->unfold2</title>+<path fill="none" stroke="black" d="M471.74,-352.7C409.48,-331.2 320.47,-300.47 257.78,-278.82"/>+<polygon fill="black" stroke="black" points="258.54,-275.38 247.95,-275.43 256.26,-282 258.54,-275.38"/>+<text text-anchor="middle" x="397.5" y="-311.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- unfold3 -->+<g id="node19" class="node">+<title>unfold3</title>+<polygon fill="none" stroke="black" points="579,-290 370,-252 579,-214 788,-252 579,-290"/>+<text text-anchor="middle" x="579" y="-255.8" font-family="Times,serif" font-size="14.00">Only that and by returning</text>+<text text-anchor="middle" x="579" y="-240.8" font-family="Times,serif" font-size="14.00">pre-built subtrees?</text>+</g>+<!-- unfold1->unfold3 -->+<g id="edge33" class="edge">+<title>unfold1->unfold3</title>+<path fill="none" stroke="black" d="M554.65,-342.51C558.38,-328.79 562.7,-312.92 566.66,-298.38"/>+<polygon fill="black" stroke="black" points="570.08,-299.14 569.32,-288.57 563.32,-297.31 570.08,-299.14"/>+<text text-anchor="middle" x="573" y="-311.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- ana -->+<g id="node25" class="node">+<title>ana</title>+<ellipse fill="none" stroke="black" cx="121" cy="-125" rx="51.99" ry="18"/>+<text text-anchor="middle" x="121" y="-121.3" font-family="Times,serif" font-size="14.00">Use ana!</text>+</g>+<!-- unfold2->ana -->+<g id="edge34" class="edge">+<title>unfold2->ana</title>+<path fill="none" stroke="black" d="M166.39,-217.5C156.2,-196.96 143.35,-171.05 133.92,-152.05"/>+<polygon fill="black" stroke="black" points="137.05,-150.48 129.47,-143.07 130.78,-153.59 137.05,-150.48"/>+<text text-anchor="middle" x="167.5" y="-184.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- futu -->+<g id="node27" class="node">+<title>futu</title>+<ellipse fill="none" stroke="black" cx="246" cy="-125" rx="54.69" ry="18"/>+<text text-anchor="middle" x="246" y="-121.3" font-family="Times,serif" font-size="14.00">Use futu!</text>+</g>+<!-- unfold2->futu -->+<g id="edge35" class="edge">+<title>unfold2->futu</title>+<path fill="none" stroke="black" d="M199.88,-217.5C210.23,-196.96 223.29,-171.05 232.87,-152.05"/>+<polygon fill="black" stroke="black" points="236.02,-153.58 237.39,-143.07 229.77,-150.43 236.02,-153.58"/>+<text text-anchor="middle" x="227" y="-184.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- apo -->+<g id="node26" class="node">+<title>apo</title>+<ellipse fill="none" stroke="black" cx="486" cy="-125" rx="51.99" ry="18"/>+<text text-anchor="middle" x="486" y="-121.3" font-family="Times,serif" font-size="14.00">Use apo!</text>+</g>+<!-- unfold3->apo -->+<g id="edge36" class="edge">+<title>unfold3->apo</title>+<path fill="none" stroke="black" d="M554.57,-218.16C538.88,-197.08 518.85,-170.15 504.49,-150.85"/>+<polygon fill="black" stroke="black" points="507.1,-148.5 498.33,-142.57 501.49,-152.68 507.1,-148.5"/>+<text text-anchor="middle" x="550.5" y="-184.8" font-family="Times,serif" font-size="14.00">yes</text>+</g>+<!-- gana -->+<g id="node28" class="node">+<title>gana</title>+<ellipse fill="none" stroke="black" cx="657" cy="-125" rx="101.23" ry="37.45"/>+<text text-anchor="middle" x="657" y="-136.3" font-family="Times,serif" font-size="14.00">Write your own</text>+<text text-anchor="middle" x="657" y="-121.3" font-family="Times,serif" font-size="14.00">recursion scheme</text>+<text text-anchor="middle" x="657" y="-106.3" font-family="Times,serif" font-size="14.00">(using gana)!</text>+</g>+<!-- unfold3->gana -->+<g id="edge37" class="edge">+<title>unfold3->gana</title>+<path fill="none" stroke="black" d="M599.9,-217.5C608.88,-203.11 619.5,-186.09 629.14,-170.65"/>+<polygon fill="black" stroke="black" points="632.35,-172.12 634.67,-161.78 626.41,-168.41 632.35,-172.12"/>+<text text-anchor="middle" x="631" y="-184.8" font-family="Times,serif" font-size="14.00">no</text>+</g>+<!-- same_as_input_type->start_folds -->+<g id="edge14" class="edge">+<title>same_as_input_type->start_folds</title>+<path fill="none" stroke="black" d="M517.7,-568.42C610.64,-547.27 788.72,-506.74 879.99,-485.97"/>+<polygon fill="black" stroke="black" points="880.91,-489.35 889.88,-483.72 879.36,-482.53 880.91,-489.35"/>+</g>+<!-- same_as_output_type->start_unfolds -->+<g id="edge16" class="edge">+<title>same_as_output_type->start_unfolds</title>+<path fill="none" stroke="black" d="M292.15,-567.86C378.46,-547.23 538.24,-509.04 626.45,-487.95"/>+<polygon fill="black" stroke="black" points="627.41,-491.32 636.32,-485.59 625.78,-484.51 627.41,-491.32"/>+</g>+<!-- neither->start_refolds -->+<g id="edge18" class="edge">+<title>neither->start_refolds</title>+<path fill="none" stroke="black" d="M88.94,-568.32C97.72,-564.25 107.63,-560.06 117,-557 230.35,-519.93 367.15,-495.5 448.67,-482.98"/>+<polygon fill="black" stroke="black" points="449.46,-486.4 458.83,-481.44 448.41,-479.48 449.46,-486.4"/>+</g>+<!-- start -->+<g id="node32" class="node">+<title>start</title>+<ellipse fill="none" stroke="black" cx="505" cy="-1037" rx="33.29" ry="18"/>+<text text-anchor="middle" x="505" y="-1033.3" font-family="Times,serif" font-size="14.00">start</text>+</g>+<!-- start->decision0 -->+<g id="edge1" class="edge">+<title>start->decision0</title>+<path fill="none" stroke="black" d="M505,-1018.88C505,-1011.25 505,-1001.83 505,-992.31"/>+<polygon fill="black" stroke="black" points="508.5,-992.02 505,-982.02 501.5,-992.02 508.5,-992.02"/>+</g>+</g>+</svg>
+ docs/github-compression.png view
binary file changed (absent → 9365 bytes)
+ examples/Expr.hs view
@@ -0,0 +1,124 @@+{-# 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.cabal view
@@ -1,35 +1,38 @@ name: recursion-schemes category: Control, Recursion-version: 3.0.0.2-license: BSD3-cabal-version: >= 1.6+version: 5.2.3+license: BSD2+cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>+maintainer: "Samuel Gélineau" <gelisam@gmail.com>,+ "Ryan Scott" <ryan.gl.scott@gmail.com>,+ "Luc Tielen" <luc.tielen@gmail.com> stability: provisional homepage: http://github.com/ekmett/recursion-schemes/ bug-reports: http://github.com/ekmett/recursion-schemes/issues-copyright: Copyright (C) 2008-2011 Edward A. Kmett-synopsis: Generalized bananas, lenses and barbed wire-description:- Generalized bananas, lenses and barbed wire- .- /Changes since 2.0/:- .- * Compatibility with transformers 0.3- .- * Resolved deprecation warnings caused by changes to Data.Typeable+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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.5, GHC==9.8.2, GHC==9.10.1+ build-type: Simple-extra-source-files: .travis.yml+extra-doc-files: docs/github-compression.png docs/flowchart.svg+extra-source-files: 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:+ CPP TypeFamilies Rank2Types FlexibleContexts@@ -38,14 +41,48 @@ StandaloneDeriving UndecidableInstances + hs-source-dirs: src+ build-depends:- base >= 4 && < 5,- transformers >= 0.2 && < 1,- comonad >= 3 && < 4,- comonad-transformers >= 3 && < 4,- free >= 3.2 && < 4+ base >= 4.9 && < 5,+ containers >= 0.4.2.1 && < 0.8,+ comonad >= 4 && < 6,+ data-fix >= 0.3.0 && < 0.4,+ free >= 4 && < 6,+ transformers >= 0.4.2.0 && < 1 + if !impl(ghc >= 8.2)+ build-depends: bifunctors >= 4 && < 6++ -- Foldable module is first, so cabal repl loads it! exposed-modules: Data.Functor.Foldable+ Data.Functor.Base + if flag(template-haskell)+ build-depends:+ template-haskell >= 2.11.0.0 && < 2.23,+ th-abstraction >= 0.4 && < 0.8+ exposed-modules:+ Data.Functor.Foldable.TH++ other-modules:+ Paths_recursion_schemes+ ghc-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type+ default-language: Haskell2010++test-suite Expr+ type: exitcode-stdio-1.0+ main-is: Expr.hs+ hs-source-dirs: examples+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ build-depends:+ base,+ HUnit <1.7,+ recursion-schemes,+ template-haskell,+ transformers >= 0.2 && < 1
+ src/Data/Functor/Base.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}++-- | Base Functors for standard types not already expressed as a fixed point.+module Data.Functor.Base+ ( ListF (..)+ , NonEmptyF(..)+ , TreeF (..), ForestF,+ ) where++import GHC.Generics (Generic, Generic1)++import Control.Applicative+import Data.Monoid++import Data.Functor.Classes+ ( Eq1(..), Ord1(..), Show1(..), Read1(..)+ , Eq2(..), Ord2(..), Show2(..), Read2(..)+ )++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)++-------------------------------------------------------------------------------+-- ListF+-------------------------------------------------------------------------------++-- | Base functor of @[]@.+data ListF a b = Nil | Cons a b+ deriving (Eq,Ord,Show,Read,Generic,Generic1,Functor,F.Foldable,T.Traversable)++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++instance Bi.Bifunctor ListF where+ bimap _ _ Nil = Nil+ bimap f g (Cons a b) = Cons (f a) (g b)++instance Bi.Bifoldable ListF where+ bifoldMap _ _ Nil = mempty+ bifoldMap f g (Cons a b) = mappend (f a) (g b)++instance Bi.Bitraversable ListF where+ bitraverse _ _ Nil = pure Nil+ bitraverse f g (Cons a b) = Cons <$> f a <*> g b++-------------------------------------------------------------------------------+-- NonEmpty+-------------------------------------------------------------------------------++-- | Base Functor for 'Data.List.NonEmpty'+data NonEmptyF a b = NonEmptyF { head :: a, tail :: Maybe b }+ deriving (Eq,Ord,Show,Read,Generic,Generic1,Functor,F.Foldable,T.Traversable)++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++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)++-------------------------------------------------------------------------------+-- Tree+-------------------------------------------------------------------------------++-- | Base functor for 'Data.Tree.Tree'.+data TreeF a b = NodeF a (ForestF a b)+ deriving (Eq,Ord,Show,Read,Generic,Generic1,Functor,F.Foldable,T.Traversable)++type ForestF a b = [b]++instance Eq2 TreeF where+ liftEq2 f g (NodeF a mb) (NodeF a' mb') = f a a' && liftEq g mb mb'++instance Eq a => Eq1 (TreeF a) where+ liftEq = liftEq2 (==)++instance Ord2 TreeF where+ liftCompare2 f g (NodeF a mb) (NodeF a' mb') = f a a' `mappend` liftCompare g mb mb'++instance Ord a => Ord1 (TreeF a) where+ liftCompare = liftCompare2 compare++instance Show a => Show1 (TreeF a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 TreeF where+ liftShowsPrec2 sa _ sb slb d (NodeF a b) = showParen (d > 10)+ $ showString "NodeF "+ . sa 11 a+ . showString " "+ . liftShowsPrec sb slb 11 b++instance Read2 TreeF where+ liftReadsPrec2 ra _ rb rlb d = readParen (d > 10) $ \s -> cons s+ where+ cons s0 = do+ ("NodeF", s1) <- lex s0+ (a, s2) <- ra 11 s1+ (mb, s3) <- liftReadsPrec rb rlb 11 s2+ return (NodeF a mb, s3)++instance Read a => Read1 (TreeF a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance Bi.Bifunctor TreeF where+ bimap f g (NodeF x xs) = NodeF (f x) (fmap g xs)++instance Bi.Bifoldable TreeF where+ bifoldMap f g (NodeF x xs) = f x `mappend` F.foldMap g xs++instance Bi.Bitraversable TreeF where+ bitraverse f g (NodeF x xs) = liftA2 NodeF (f x) (T.traverse g xs)
+ src/Data/Functor/Foldable.hs view
@@ -0,0 +1,1043 @@+{-# LANGUAGE TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables, DefaultSignatures, MultiParamTypeClasses, TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : "Samuel Gélineau" <gelisam@gmail.com>,+-- "Luc Tielen" <luc.tielen@gmail.com>,+-- "Ryan Scott" <ryan.gl.scott@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Data.Functor.Foldable+ (+ -- * Base functors+ Base+ , ListF(..)+ -- * Type classes+ , Recursive(project)+ , Corecursive(embed)+ -- * Folding functions+ -- $foldingFunctions+ , fold+ , cata+ , cataA+ , para+ , histo+ , zygo+ -- * Unfolding functions+ , unfold+ , ana+ , apo+ , futu+ -- * Combining unfolds and folds+ , refold+ , hylo+ , chrono+ -- * Changing representation+ , refix+ , hoist+ , transverse+ , cotransverse+ -- * Advanced usage+ -- ** Mendler-style recursion-schemes+ , mcata+ , mpara+ , mhisto+ , mzygo+ , mana+ , mapo+ , mfutu+ -- ** Fokkinga's recursion-schemes+ , prepro+ , postpro+ -- ** Elgot (co)algebras+ , elgot+ , coelgot+ -- ** Generalized recursion-schemes+ , gfold+ , gcata+ , gpara+ , ghisto+ , gzygo+ , gunfold+ , gana+ , gapo+ , gfutu+ , grefold+ , ghylo+ , gchrono+ , gprepro+ , gpostpro+ , distCata+ , distPara+ , distParaT+ , distHisto+ , distGHisto+ , distZygo+ , distZygoT+ , distAna+ , distApo+ , distGApo+ , distGApoT+ , distFutu+ , distGFutu+ -- ** Zygohistomorphic prepromorphisms+ , zygoHistoPrepro+ ) where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Trans.Class+import Control.Comonad.Trans.Env (EnvT(..))+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.Functor.Compose (Compose(..))+import Data.List.NonEmpty(NonEmpty((:|)), nonEmpty, toList)+import Data.Tree (Tree (..))+import GHC.Generics (Generic (..), M1 (..), V1, U1, K1 (..), (:+:) (..), (:*:) (..))+import Numeric.Natural+import Prelude++import Data.Functor.Base hiding (head, tail)+import qualified Data.Functor.Base as NEF (NonEmptyF(..))++import Data.Fix (Fix (..), unFix, Mu (..), Nu (..))++-- $setup+-- >>> :set -XDeriveFunctor -XScopedTypeVariables -XLambdaCase -XGADTs -XFlexibleContexts+-- >>> import Control.Applicative (Const (..), Applicative (..))+-- >>> import Control.Comonad+-- >>> import Control.Comonad.Cofree (Cofree(..))+-- >>> import Control.Monad (void)+-- >>> import Control.Monad.Trans.Reader (Reader, ask, local, runReader)+-- >>> import Data.Char (toUpper)+-- >>> import Data.Fix (Fix (..))+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (intercalate, partition)+-- >>> import Data.List.NonEmpty (NonEmpty (..))+-- >>> import Data.Maybe (maybeToList)+-- >>> import Data.Tree (Tree (..), drawTree)+-- >>> import Numeric.Natural+--+-- >>> import Data.Functor.Base+--+-- >>> let showTree = putStrLn . go where go (Node x xs) = if null xs then x else "(" ++ unwords (x : map go xs) ++ ")"+--+-- >>> let myTree = Node 0 [Node 1 [], Node 2 [], Node 3 [Node 31 [Node 311 [Node 3111 [], Node 3112 []]]]]++-- $foldingFunctions+-- Folding functions allow you to reduce a recursive structure down to a value. The value can be a simple type such as 'Int' or 'String', or it can also be a recursive structure. Each of the functions below will be accompanied by an example which folds the following @Tree Int@ down to some 'String'.+--+-- >>> putStr $ drawTree $ fmap show myTree+-- 0+-- |+-- +- 1+-- |+-- +- 2+-- |+-- `- 3+-- |+-- `- 31+-- |+-- `- 311+-- |+-- +- 3111+-- |+-- `- 3112++-- | Obtain the base functor for a recursive datatype.+--+-- The core idea of this library is that instead of writing recursive functions+-- on a recursive datatype, we prefer to write non-recursive functions on a+-- related, non-recursive datatype we call the "base functor".+--+-- For example, @[a]@ is a recursive type, and its corresponding base functor is+-- @'ListF' a@:+--+-- @+-- data 'ListF' a b = 'Nil' | 'Cons' a b+-- type instance 'Base' [a] = 'ListF' a+-- @+--+-- The relationship between those two types is that if we replace @b@ with+-- @'ListF' a@, we obtain a type which is isomorphic to @[a]@.+--+type family Base t :: * -> *++-- | A recursive datatype which can be unrolled one recursion layer at a time.+--+-- For example, a value of type @[a]@ can be unrolled into a @'ListF' a [a]@.+-- If that unrolled value is a 'Cons', it contains another @[a]@ which can be+-- unrolled as well, and so on.+--+-- Typically, 'Recursive' types also have a 'Corecursive' instance, in which+-- case 'project' and 'embed' are inverses.+class Functor (Base t) => Recursive t where+ -- | Unroll a single recursion layer.+ --+ -- >>> project [1,2,3]+ -- Cons 1 [2,3]+ project :: t -> Base t t+ default project :: (Generic t, Generic (Base t t), GCoerce (Rep t) (Rep (Base t t))) => t -> Base t t+ project = to . gcoerce . from++ -- | An alias for 'fold'.+ --+ -- 'fold' is by far the most common recursion-scheme, because working one layer at a time is the most common strategy for writing a recursive function. But there are also other, rarer strategies. Researchers have given names to the most common strategies, and their name for 'fold' is "catamorphism". They also give its @Base t a -> a@ argument a special name, "(@Base t@)-algebra". More generally, a function of the form @f a -> a@ is called an "f-algebra".+ --+ -- The names might seem intimidating at first, but using the standard nomenclature has benefits. If you program with others, it can be useful to have a shared vocabulary to refer to those recursion patterns. For example, you can discuss which type of recursion is the most appropriate for the problem at hand. Names can also help to structure your thoughts while writing recursive functions.+ --+ -- The rest of this module lists a few of the other recursion-schemes which are common enough to have a name. In this section, we restrict our attention to those which fold a recursive structure down to a value. In the examples all functions will be of type @Tree Int -> String@.+ cata :: (Base t a -> a) -> t -> a+ cata f = c where c = f . fmap c . project++ -- | A variant of 'cata' in which recursive positions also include the+ -- original sub-tree, in addition to the result of folding that sub-tree.+ --+ -- For our running example, let's add a number to each node indicating how+ -- many children are below it. To do so, we will need to count those nodes+ -- from the original sub-tree.+ --+ -- >>> :{+ -- let pprint4 :: Tree Int -> String+ -- pprint4 = flip runReader 0 . para go+ -- where+ -- go :: TreeF Int (Tree Int, Reader Int String)+ -- -> Reader Int String+ -- go (NodeF i trss) = do+ -- -- trss :: [(Tree Int, Reader Int String)]+ -- -- ts :: [Tree Int]+ -- -- rss :: [Reader Int String]+ -- -- ss :: [String]+ -- let (ts, rss) = unzip trss+ -- let count = sum $ fmap length ts+ -- ss <- local (+ 2) $ sequence rss+ -- indent <- ask+ -- let s = replicate indent ' '+ -- ++ "* " ++ show i+ -- ++ " (" ++ show count ++ ")"+ -- pure $ intercalate "\n" (s : ss)+ -- :}+ --+ -- >>> putStrLn $ pprint4 myTree+ -- * 0 (7)+ -- * 1 (0)+ -- * 2 (0)+ -- * 3 (4)+ -- * 31 (3)+ -- * 311 (2)+ -- * 3111 (0)+ -- * 3112 (0)+ --+ -- One common use for 'para' is to construct a new tree which reuses most of+ -- the sub-trees from the original. In the following example, we insert a new+ -- node under the leftmost leaf. This requires allocating new nodes along a+ -- path from the root to that leaf, while keeping every other sub-tree+ -- untouched.+ --+ -- >>> :{+ -- let insertLeftmost :: Int -> Tree Int -> Tree Int+ -- insertLeftmost new = para go+ -- where+ -- go :: TreeF Int (Tree Int, Tree Int)+ -- -> Tree Int+ -- go (NodeF i []) = Node i [Node new []]+ -- go (NodeF i ((_orig, recur) : tts))+ -- -- tts :: [(Tree Int, Tree Int)]+ -- = let (origs, _recurs) = unzip tts+ -- in Node i (recur : origs)+ -- :}+ --+ -- >>> putStrLn $ pprint4 $ insertLeftmost 999 myTree+ -- * 0 (8)+ -- * 1 (1)+ -- * 999 (0)+ -- * 2 (0)+ -- * 3 (4)+ -- * 31 (3)+ -- * 311 (2)+ -- * 3111 (0)+ -- * 3112 (0)+ 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++-- | A recursive datatype which can be rolled up one recursion layer at a time.+--+-- For example, a value of type @'ListF' a [a]@ can be rolled up into a @[a]@.+-- This @[a]@ can then be used in a 'Cons' to construct another @'ListF' a [a]@,+-- which can be rolled up as well, and so on.+--+-- Typically, 'Corecursive' types also have a 'Recursive' instance, in which+-- case 'embed' and 'project' are inverses.+class Functor (Base t) => Corecursive t where++ -- | Roll up a single recursion layer.+ --+ -- >>> embed (Cons 1 [2,3])+ -- [1,2,3]+ embed :: Base t t -> t+ default embed :: (Generic t, Generic (Base t t), GCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t+ embed = to . gcoerce . from++ -- | An alias for 'unfold'.+ 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++-- | An alias for 'refold'.+hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+hylo f g = h where h = f . fmap h . g++-- | Folds a recursive type down to a value, one layer at a time.+--+-- >>> :{+-- let mySum :: [Int] -> Int+-- mySum = fold $ \case+-- Nil -> 0+-- Cons x sumXs -> x + sumXs+-- :}+--+-- >>> mySum [10,11,12]+-- 33+--+-- In our running example, one layer consists of an 'Int' and a list of recursive positions. In @Tree Int@, those recursive positions contain sub-trees of type @Tree Int@. Since we are working one layer at a time, the @Base t a -> a@ function is not given a @Tree Int@, but a @TreeF Int String@. That is, each recursive position contains the 'String' resulting from recursively folding the corresponding sub-tree.+--+-- >>> :{+-- let pprint1 :: Tree Int -> String+-- pprint1 = fold $ \case+-- NodeF i [] -> show i+-- NodeF i ss -> show i ++ ": [" ++ intercalate ", " ss ++ "]"+-- :}+--+-- >>> putStrLn $ pprint1 myTree+-- 0: [1, 2, 3: [31: [311: [3111, 3112]]]]+--+-- More generally, the 't' argument is the recursive value, the 'a' is the final result, and the @Base t a -> a@ function explains how to reduce a single layer full of recursive results down to a result.+fold :: Recursive t => (Base t a -> a) -> t -> a+fold = cata++-- | A generalization of 'unfoldr'. The starting seed is expanded into a base+-- functor whose recursive positions contain more seeds, which are themselves+-- expanded, and so on.+--+-- >>> :{+-- >>> let ourEnumFromTo :: Int -> Int -> [Int]+-- >>> ourEnumFromTo lo hi = ana go lo where+-- >>> go i = if i > hi then Nil else Cons i (i + 1)+-- >>> :}+--+-- >>> ourEnumFromTo 1 4+-- [1,2,3,4]+unfold :: Corecursive t => (a -> Base t a) -> a -> t+unfold = ana++-- | An optimized version of @fold f . unfold g@.+--+-- Useful when your recursion structure is shaped like a particular recursive+-- datatype, but you're neither consuming nor producing that recursive datatype.+-- For example, the recursion structure of quick sort is a binary tree, but its+-- input and output is a list, not a binary tree.+--+-- >>> data BinTreeF a b = Tip | Branch b a b deriving (Functor)+--+-- >>> :{+-- >>> let quicksort :: Ord a => [a] -> [a]+-- >>> quicksort = refold merge split where+-- >>> split [] = Tip+-- >>> split (x:xs) = let (l, r) = partition (<x) xs in Branch l x r+-- >>>+-- >>> merge Tip = []+-- >>> merge (Branch l x r) = l ++ [x] ++ r+-- >>> :}+--+-- >>> quicksort [1,5,2,8,4,9,8]+-- [1,2,4,5,8,8,9]+refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+refold = hylo++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 (Tree a) = TreeF a+instance Recursive (Tree a) where+ project (Node x xs) = NodeF x xs+instance Corecursive (Tree a) where+ embed (NodeF x xs) = Node x xs++type instance Base Natural = Maybe+instance Recursive Natural where+ project 0 = Nothing+ 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 = f . fmap (hylo alg coalg) . g where+ coalg = fmap join . m . liftM g+ alg = fmap f . w . fmap duplicate+grefold w m f g a = ghylo w m f g a++futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t+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+-------------------------------------------------------------------------------++type instance Base (Fix f) = f+instance Functor f => Recursive (Fix f) where+ project (Fix a) = a+instance Functor f => Corecursive (Fix f) where+ embed = Fix++-- | Convert from one recursive type to another.+--+-- >>> showTree $ hoist (\(NonEmptyF h t) -> NodeF [h] (maybeToList t)) ( 'a' :| "bcd")+-- (a (b (c d)))+--+hoist :: (Recursive s, Corecursive t)+ => (forall a. Base s a -> Base t a) -> s -> t+hoist n = cata (embed . n)++-- | Convert from one recursive representation to another.+--+-- >>> refix ["foo", "bar"] :: Fix (ListF String)+-- Fix (Cons "foo" (Fix (Cons "bar" (Fix Nil))))+--+refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t+refix = cata embed++-------------------------------------------------------------------------------+-- 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)++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))++type instance Base (Nu f) = f+instance Functor f => Corecursive (Nu f) where+ embed = colambek+ ana = Nu+instance Functor f => Recursive (Nu f) where+ project (Nu f a) = Nu f <$> f a++-- | Church encoded free monads are Recursive/Corecursive, in the same way that+-- 'Mu' is.+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++-- TODO: link from 'para' to 'zygo'+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++-- | A variant of 'cata' which includes the results of all the+-- descendents, not just the direct children.+--+-- Like 'para', a sub-tree is provided for each recursive position. Each+-- node in that sub-tree is annotated with the result for that+-- descendent. The 'Cofree' type is used to add those annotations.+--+-- For our running example, let's recreate GitHub's directory compression+-- algorithm. Notice that in [the repository for this+-- package](https://github.com/recursion-schemes/recursion-schemes), GitHub+-- displays @src\/Data\/Functor@, not @src@:+--+-- +--+-- GitHub does this because @src@ only contains one entry: @Data@. Similarly,+-- @Data@ only contains one entry: @Functor@. @Functor@ contains several+-- entries, so the compression stops there. This helps users get to the+-- interesting folders more quickly.+--+-- Before we use 'histo', we need to define a helper function 'rollup'.+-- It collects nodes until it reaches a node which doesn't have exactly one+-- child. It also returns the labels of that node's children.+--+-- >>> :{+-- let rollup :: [Cofree (TreeF node) label]+-- -> ([node], [label])+-- rollup [_ :< NodeF node cofrees] =+-- let (nodes, label) = rollup cofrees+-- in (node : nodes, label)+-- rollup cofrees =+-- ([], fmap extract cofrees)+-- :}+--+-- >>> let foobar xs = 1 :< NodeF "foo" [2 :< NodeF "bar" xs]+-- >>> rollup [foobar []]+-- (["foo","bar"],[])+-- >>> rollup [foobar [3 :< NodeF "baz" [], 4 :< NodeF "quux" []]]+-- (["foo","bar"],[3,4])+--+-- The value @foobar []@ can be interpreted as the tree @NodeF "foo"+-- [NodeF "bar" []]@, plus two annotations. The @"foo"@ node is annotated+-- with @1@, while the @"bar"@ node is annotated with @2@. When we call+-- 'histo' below, those annotations are recursive results of type @Int ->+-- String@.+--+-- >>> :{+-- let pprint5 :: Tree Int -> String+-- pprint5 t = histo go t 0+-- where+-- go :: TreeF Int (Cofree (TreeF Int) (Int -> String))+-- -> Int -> String+-- go (NodeF node cofrees) indent+-- -- cofrees :: [Cofree (TreeF Int) (Int -> String)]+-- -- fs :: [Int -> String]+-- = let indent' = indent + 2+-- (nodes, fs) = rollup cofrees+-- ss = map (\f -> f indent') fs+-- s = replicate indent ' '+-- ++ "* " ++ intercalate " / " (fmap show (node : nodes))+-- in intercalate "\n" (s : ss)+-- :}+--+-- >>> putStrLn $ pprint5 myTree+-- * 0+-- * 1+-- * 2+-- * 3 / 31 / 311+-- * 3111+-- * 3112+--+-- One common use for 'histo' is to cache the value computed for smaller+-- sub-trees. In the Fibonacci example below, the recursive type is 'Natural',+-- which is isomorphic to @[()]@. Our annotated sub-tree is thus isomorphic to+-- a list of annotations. In our case, each annotation is the result which was+-- computed for a smaller number. We thus have access to a list which caches+-- all the Fibonacci numbers we have computed so far.+--+-- >>> :{+-- let fib :: Natural -> Integer+-- fib = histo go+-- where+-- go :: Maybe (Cofree Maybe Integer) -> Integer+-- go Nothing = 1+-- go (Just (_ :< Nothing)) = 1+-- go (Just (fibNMinus1 :< Just (fibNMinus2 :< _)))+-- = fibNMinus1 + fibNMinus2+-- :}+--+-- >>> fmap fib [0..10]+-- [1,1,2,3,5,8,13,21,34,55,89]+--+-- In general, @Cofree f a@ can be thought of as a cache that has the same+-- shape as the recursive structure which was given as input.+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 = c where c = psi c . unFix++-- | Mendler-style recursion+--+-- @since 5.2.2+mpara :: (forall y. (y -> c) -> (y -> Fix f) -> f y -> c) -> Fix f -> c+mpara psi = c where c = psi c id . unFix++-- | Mendler-style semi-mutual recursion+--+-- @since 5.2.2+mzygo :: (forall y. (y -> b) -> f y -> b) -> (forall y. (y -> c) -> (y -> b) -> f y -> c) -> Fix f -> c+mzygo phi psi = c where c = psi c (mcata phi) . unFix++-- | Mendler-style course-of-value iteration+mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c+mhisto psi = c where c = psi c unFix . unFix++-- | Mendler-style coiteration+--+-- @since 5.2.2+mana :: (forall y. (x -> y) -> x -> f y) -> x -> Fix f+mana phi = c where c = Fix . phi c++-- | Mendler-style corecursion+--+-- @since 5.2.2+mapo :: (forall y. (Fix f -> y) -> (x -> y) -> x -> f y) -> x -> Fix f+mapo phi = c where c = Fix . phi id c++-- | Mendler-style course-of-values coiteration+--+-- @since 5.2.2+mfutu :: (forall y. (f y -> y) -> (x -> y) -> x -> f y) -> x -> Fix f+mfutu phi = c where c = Fix . phi Fix c++-- | 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: <http://comonad.com/reader/2008/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 <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>+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+-------------------------------------------------------------------------------++-- | A specialization of 'cata' for effectful folds.+--+-- 'cataA' is the same as 'cata', but with a more specialized type. The only+-- reason it exists is to make it easier to discover how to use this library+-- with effects.+--+-- For our running example, let's improve the output format of our+-- pretty-printer by using indentation. To do so, we will need to keep track of+-- the current indentation level. We will do so using a @Reader Int@ effect.+-- Our recursive positions will thus contain @Reader Int String@ actions, not+-- @String@s. This means we need to run those actions in order to get the+-- results.+--+-- >>> :{+-- let pprint2 :: Tree Int -> String+-- pprint2 = flip runReader 0 . cataA go+-- where+-- go :: TreeF Int (Reader Int String)+-- -> Reader Int String+-- go (NodeF i rss) = do+-- -- rss :: [Reader Int String]+-- -- ss :: [String]+-- ss <- local (+ 2) $ sequence rss+-- indent <- ask+-- let s = replicate indent ' ' ++ "* " ++ show i+-- pure $ intercalate "\n" (s : ss)+-- :}+--+-- >>> putStrLn $ pprint2 myTree+-- * 0+-- * 1+-- * 2+-- * 3+-- * 31+-- * 311+-- * 3111+-- * 3112+--+-- The fact that the recursive positions contain 'Reader' actions instead of+-- 'String's gives us some flexibility. Here, we are able to increase the+-- indentation by running those actions inside a 'local' block. More generally,+-- we can control the order of their side-effects, interleave them with other+-- effects, etc.+--+-- A similar technique is to specialize 'cata' so that the result is a+-- function. This makes it possible for data to flow down in addition to up.+-- In this modified version of our running example, the indentation level flows+-- down from the root to the leaves, while the resulting strings flow up from+-- the leaves to the root.+--+-- >>> :{+-- let pprint3 :: Tree Int -> String+-- pprint3 t = cataA go t 0+-- where+-- go :: TreeF Int (Int -> String)+-- -> Int -> String+-- go (NodeF i fs) indent+-- -- fs :: [Int -> String]+-- = let indent' = indent + 2+-- ss = map (\f -> f indent') fs+-- s = replicate indent ' ' ++ "* " ++ show i+-- in intercalate "\n" (s : ss)+-- :}+--+-- >>> putStrLn $ pprint3 myTree+-- * 0+-- * 1+-- * 2+-- * 3+-- * 31+-- * 311+-- * 3111+-- * 3112+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' :: forall a b. (a -> a -> b) -> [a] -> [a] -> [b]+-- zipWith' f xs ys = cotransverse g (Pair xs ys) where+-- g :: Pair (ListF a c) -> ListF b (Pair c)+-- g (Pair Nil _) = Nil+-- g (Pair _ Nil) = Nil+-- g (Pair (Cons x a) (Cons y b)) = Cons (f x y) (Pair a b)+-- :}+--+-- >>> 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)
+ src/Data/Functor/Foldable/TH.hs view
@@ -0,0 +1,495 @@+{-# LANGUAGE CPP, PatternGuards, Rank2Types #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+-- This OPTIONS_GHC line is a workaround for+-- https://gitlab.haskell.org/ghc/ghc/-/issues/18320, a bug which only occurs+-- when running specific TemplateHaskell code while both profiling and+-- optimisations are enabled. The code in this file triggers the bug, so until+-- it is fixed, we work around the issue by disabling optimisations in this+-- file. The code in this file only runs at compile-time, the code _generated_+-- by makeBaseFunctor will still get optimized if the file which calls+-- makeBaseFunctor is optimized.+{-# OPTIONS_GHC -O0 #-}+module Data.Functor.Foldable.TH+ ( MakeBaseFunctor(..)+ , 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.Datatype.TyVarBndr+import Data.Char (GeneralCategory (..), generalCategory)++import Data.Functor.Foldable++#if !MIN_VERSION_template_haskell(2,21,0) && !MIN_VERSION_th_abstraction(0,6,0)+type TyVarBndrVis = TyVarBndrUnit+#endif++-- $setup+-- >>> :set -XTemplateHaskell -XTypeFamilies -XDeriveTraversable -XScopedTypeVariables+-- >>> import Data.Functor.Foldable+-- >>> import Language.Haskell.TH (Q)+-- >>> let asQ :: Q a -> Q a; asQ = id++-- | 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+-- @+--+--+-- /Notes:/+--+-- 'makeBaseFunctor' works properly only with ADTs.+-- Existentials and GADTs aren't supported,+-- as we don't try to do better than+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>.+--+-- Allowing 'makeBaseFunctor' to take both 'Name's and 'Dec's as an argument is why it exists as a method in a type class.+-- For trickier data-types, like rose-tree (see also 'Cofree'):+--+-- @+-- data Rose f a = Rose a (f (Rose f a))+-- @+--+-- we can invoke 'makeBaseFunctor' with an instance declaration+-- to provide needed context for instances. (c.f. @StandaloneDeriving@)+--+-- @+-- 'makeBaseFunctor' [d| instance Functor f => Recursive (Rose f a) |]+-- @+--+-- will create+--+-- @+-- data RoseF f a r = RoseF a (f fr)+-- deriving ('Functor', 'Foldable', 'Traversable')+--+-- type instance 'Base' (Rose f a) = RoseF f a+--+-- instance Functor f => 'Recursive' (Rose f a) where+-- 'project' (Rose x xs) = RoseF x xs+--+-- instance Functor f => 'Corecursive' (Rose f a) where+-- 'embed' (RoseF x xs) = Rose x xs+-- @+--+-- Some doctests:+--+-- >>> data Expr a = Lit a | Add (Expr a) (Expr a) | Expr a :* [Expr a]; makeBaseFunctor ''Expr+--+-- >>> :t AddF+-- AddF :: r -> r -> ExprF a r+--+-- >>> data Rose f a = Rose a (f (Rose f a)); makeBaseFunctor $ asQ [d| instance Functor f => Recursive (Rose f a) |]+--+-- >>> :t RoseF+-- RoseF :: a -> f r -> RoseF f a r+--+-- >>> let rose = Rose 1 (Just (Rose 2 (Just (Rose 3 Nothing))))+-- >>> cata (\(RoseF x f) -> x + maybe 0 id f) rose+-- 6+--+class MakeBaseFunctor a where+ -- |+ -- @+ -- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'+ -- @+ makeBaseFunctor :: a -> DecsQ+ makeBaseFunctor = makeBaseFunctorWith baseRules++ -- | Build base functor with a custom configuration.+ makeBaseFunctorWith :: BaseRules -> a -> DecsQ++instance MakeBaseFunctor a => MakeBaseFunctor [a] where+ makeBaseFunctorWith rules a = fmap concat (T.traverse (makeBaseFunctorWith rules) a)++instance MakeBaseFunctor a => MakeBaseFunctor (Q a) where+ makeBaseFunctorWith rules a = makeBaseFunctorWith rules =<< a++instance MakeBaseFunctor Name where+ makeBaseFunctorWith rules name = reifyDatatype name >>= makePrimForDI rules Nothing++-- | Expects declarations of 'Recursive' or 'Corecursive' instances, e.g.+--+-- @+-- makeBaseFunctor [d| instance Functor f => Recursive (Rose f a) |]+-- @+--+-- This way we can provide a context for generated instances.+-- Note that this instance's 'makeBaseFunctor' still generates all of+-- 'Base' type instance, 'Recursive' and 'Corecursive' instances.+--+instance MakeBaseFunctor Dec where+ makeBaseFunctorWith rules (InstanceD overlaps ctx classHead []) = do+ let instanceFor = InstanceD overlaps ctx+ case classHead of+ ConT u `AppT` t | u == recursiveTypeName || u == corecursiveTypeName -> do+ name <- headOfType t+ di <- reifyDatatype name+ makePrimForDI rules (Just $ \n -> instanceFor (ConT n `AppT` t)) di+ _ -> fail $ "makeBaseFunctor: expected an instance head like `ctx => Recursive (T a b ...)`, got " ++ show classHead++ makeBaseFunctorWith _ _ = fail "makeBaseFunctor(With): expected an empty instance declaration"++-- | Rules of renaming data names+data BaseRules = BaseRules+ { _baseRulesType :: Name -> Name+ , _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+ -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance+ -> DatatypeInfo+ -> DecsQ+makePrimForDI rules mkInstance'+ (DatatypeInfo { datatypeName = tyName+ , datatypeInstTypes = instTys+ , datatypeCons = cons+ , datatypeVariant = variant }) = do+ checkAllowed+ makePrimForDI' rules mkInstance'+ (variant == Newtype) tyName+ (map toTyVarBndr instTys) cons+ where+ checkAllowed =+ case variant of+ Datatype -> pure ()+ Newtype -> pure ()+ DataInstance -> dataFamilyError+ NewtypeInstance -> dataFamilyError+#if MIN_VERSION_th_abstraction(0,5,0)+ TH.Abs.TypeData -> fail "makeBaseFunctor: `type data` declarations are not supported."+#endif++ dataFamilyError = fail "makeBaseFunctor: Data families are currently not supported."++ toTyVarBndr :: Type -> TyVarBndrVis+ toTyVarBndr (VarT n) = plainTV n+ toTyVarBndr (SigT (VarT n) k) = kindedTV n k+ toTyVarBndr _ = error "toTyVarBndr"++makePrimForDI' :: BaseRules+ -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance+ -> Bool -> Name+ -> [TyVarBndrVis]+ -> [ConstructorInfo] -> DecsQ+makePrimForDI' rules mkInstance' 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+#if MIN_VERSION_template_haskell(2,12,0)+ derivStrat <- do+ e <- isExtEnabled DerivingStrategies+ pure $ if e then Just StockStrategy else Nothing+#endif+ let dataDec = case consF of+ [conF] | isNewtype ->+ NewtypeD [] tyNameF varsF Nothing conF deriveds+ _ ->+ DataD [] tyNameF varsF Nothing consF deriveds+ where+ deriveds =+#if MIN_VERSION_template_haskell(2,12,0)+ [DerivClause derivStrat+ [ ConT functorTypeName+ , ConT foldableTypeName+ , ConT traversableTypeName ]]+#else+ [ ConT functorTypeName+ , ConT foldableTypeName+ , ConT traversableTypeName ]+#endif++ -- type instance Base+ baseDec <- tySynInstDCompat baseTypeName Nothing+ [pure s] (pure $ conAppsT tyNameF vars')++ let mkInstance :: Name -> [Dec] -> Dec+ mkInstance = case mkInstance' of+ Just f -> f+ Nothing -> \n ->+ InstanceD Nothing [] (ConT n `AppT` s)++ -- instance Recursive+ projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'+ let recursiveDec = mkInstance recursiveTypeName [projDec]++ -- instance Corecursive+ embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'+ let corecursiveDec = mkInstance corecursiveTypeName [embedDec]++ -- 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")+ 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+-------------------------------------------------------------------------------++headOfType :: Type -> Q Name+headOfType (AppT t _) = headOfType t+headOfType (VarT n) = return n+headOfType (ConT n) = return n+headOfType t = fail $ "headOfType: " ++ show t++-- | Extract type variables+typeVars :: [TyVarBndr_ flag] -> [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+ 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)+ -- 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+ | [bang1, bang2] <- bangs+ , [fty1, fty2] <- ftys+ -> InfixC (bang1, fty1) name (bang2, fty2)++ | otherwise+ -> error $ "makeBaseFunctor: Encountered an InfixConstructor "+ ++ "without exactly two fields"+ where+ 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++-------------------------------------------------------------------------------+-- 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` ",;()[]{}`"++-------------------------------------------------------------------------------+-- TH-quoted names+-------------------------------------------------------------------------------+-- Note that this module only TemplateHaskellQuotes, not TemplateHaskell,+-- which makes lens able to be used in stage1 cross-compilers.++baseTypeName :: Name+baseTypeName = ''Base++recursiveTypeName :: Name+recursiveTypeName = ''Recursive++corecursiveTypeName :: Name+corecursiveTypeName = ''Corecursive++projectValName :: Name+projectValName = 'project++embedValName :: Name+embedValName = 'embed++functorTypeName :: Name+functorTypeName = ''Functor++foldableTypeName :: Name+foldableTypeName = ''Foldable++traversableTypeName :: Name+traversableTypeName = ''Traversable