{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}
#include "recursion-schemes-common.h"

#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE ConstrainedClassMethods #-}
#endif
#if HAS_GENERIC
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables, DefaultSignatures, MultiParamTypeClasses, TypeOperators #-}
#endif
#endif

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  : "Samuel Gélineau" <gelisam@gmail.com>,
--               "Oleg Grenrus" <oleg.grenrus@iki.fi>,
--               "Ryan Scott" <ryan.gl.scott@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Data.Functor.Foldable
  (
  -- * Base functors for fixed points
    Base
  , ListF(..)
  -- * Fixed points
  , Fix(..), unfix
  , Mu(..), hoistMu
  , Nu(..), hoistNu
  -- * Folding
  , Recursive(..)
  -- ** Combinators
  , gapo
  , gcata
  , zygo
  , gzygo
  , histo
  , ghisto
  , futu
  , gfutu
  , chrono
  , gchrono
  -- ** Distributive laws
  , distCata
  , distPara
  , distParaT
  , distZygo
  , distZygoT
  , distHisto
  , distGHisto
  , distFutu
  , distGFutu
  -- * Unfolding
  , Corecursive(..)
  -- ** Combinators
  , gana
  -- ** Distributive laws
  , distAna
  , distApo
  , distGApo
  , distGApoT
  -- * Refolding
  , hylo
  , ghylo
  -- ** Changing representation
  , hoist
  , refix
  -- * Common names
  , fold, gfold
  , unfold, gunfold
  , refold, grefold
  -- * Mendler-style
  , mcata
  , mhisto
  -- * Elgot (co)algebras
  , elgot
  , coelgot
  -- * Zygohistomorphic prepromorphisms
  , zygoHistoPrepro
  -- * Effectful combinators
  , cataA
  , transverse
  , cotransverse
  ) where

import Control.Applicative
import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Trans.Env
import qualified Control.Comonad.Cofree as Cofree
import Control.Comonad.Cofree (Cofree(..))
import           Control.Comonad.Trans.Cofree (CofreeF, CofreeT(..))
import qualified Control.Comonad.Trans.Cofree as CCTC
import Control.Monad (liftM, join)
import Control.Monad.Free (Free(..))
import qualified Control.Monad.Free.Church as CMFC
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import           Control.Monad.Trans.Free (FreeF, FreeT(..))
import qualified Control.Monad.Trans.Free as CMTF
import Data.Functor.Identity
import Control.Arrow
import Data.Function (on)
import Data.Functor.Classes
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty(NonEmpty((:|)), nonEmpty, toList)
import Text.Read
import Text.Show
#ifdef __GLASGOW_HASKELL__
import Data.Data hiding (gunfold)
#if HAS_POLY_TYPEABLE
#else
import qualified Data.Data as Data
#endif
#if HAS_GENERIC
import GHC.Generics (Generic (..), M1 (..), V1, U1, K1 (..), (:+:) (..), (:*:) (..))
#endif
#if HAS_GENERIC1
import GHC.Generics (Generic1)
#endif
#endif
import Numeric.Natural
import Data.Monoid (Monoid (..))
import Prelude

import qualified Data.Foldable as F
import qualified Data.Traversable as T

import qualified Data.Bifunctor as Bi
import qualified Data.Bifoldable as Bi
import qualified Data.Bitraversable as Bi

import           Data.Functor.Base hiding (head, tail)
import qualified Data.Functor.Base as NEF (NonEmptyF(..))

-- $setup
-- >>> :set -XDeriveFunctor
-- >>> import Control.Monad (void)
-- >>> import Data.Char (toUpper)

type family Base t :: * -> *

class Functor (Base t) => Recursive t where
  project :: t -> Base t t
#ifdef HAS_GENERIC
  default project :: (Generic t, Generic (Base t t), GCoerce (Rep t) (Rep (Base t t))) => t -> Base t t
  project = Rep (Base t t) Any -> Base t t
forall a x. Generic a => Rep a x -> a
to (Rep (Base t t) Any -> Base t t)
-> (t -> Rep (Base t t) Any) -> t -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> Rep (Base t t) Any
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce (Rep t Any -> Rep (Base t t) Any)
-> (t -> Rep t Any) -> t -> Rep (Base t t) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from
#endif

  cata :: (Base t a -> a) -- ^ a (Base t)-algebra
       -> t               -- ^ fixed point
       -> a               -- ^ result
  cata f :: Base t a -> a
f = t -> a
c where c :: t -> a
c = Base t a -> a
f (Base t a -> a) -> (t -> Base t a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> Base t t -> Base t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> a
c (Base t t -> Base t a) -> (t -> Base t t) -> t -> Base t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project

  para :: (Base t (t, a) -> a) -> t -> a
  para t :: Base t (t, a) -> a
t = t -> a
p where p :: t -> a
p x :: t
x = Base t (t, a) -> a
t (Base t (t, a) -> a)
-> (Base t t -> Base t (t, a)) -> Base t t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> (t, a)) -> Base t t -> Base t (t, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (t -> a -> (t, a)) -> (t -> a) -> t -> (t, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> a
p) (Base t t -> a) -> Base t t -> a
forall a b. (a -> b) -> a -> b
$ t -> Base t t
forall t. Recursive t => t -> Base t t
project t
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 :: forall b. Base t (w b) -> w (Base t b)
t = (Base t t -> t)
-> (forall b. Base t (w b) -> w (Base t b))
-> (Base t (EnvT t w a) -> a)
-> t
-> a
forall t (w :: * -> *) b a.
(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 Base t t -> t
forall t. Corecursive t => Base t t -> t
embed forall b. Base t (w b) -> w (Base t b)
t

  -- | Fokkinga's prepromorphism
  prepro
    :: Corecursive t
    => (forall b. Base t b -> Base t b)
    -> (Base t a -> a)
    -> t
    -> a
  prepro e :: forall b. Base t b -> Base t b
e f :: Base t a -> a
f = t -> a
c where c :: t -> a
c = Base t a -> a
f (Base t a -> a) -> (t -> Base t a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> Base t t -> Base t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> a
c (t -> a) -> (t -> t) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Base t b -> Base t b) -> t -> t
forall s t.
(Recursive s, Corecursive t) =>
(forall a. Base s a -> Base t a) -> s -> t
hoist forall b. Base t b -> Base t b
e) (Base t t -> Base t a) -> (t -> Base t t) -> t -> Base t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
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 :: forall b. Base t (w b) -> w (Base t b)
k e :: forall b. Base t b -> Base t b
e f :: Base t (w a) -> a
f = w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (w a -> a) -> (t -> w a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> w a
c where c :: t -> w a
c = (Base t (w a) -> a) -> w (Base t (w a)) -> w a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t (w a) -> a
f (w (Base t (w a)) -> w a) -> (t -> w (Base t (w a))) -> t -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base t (w (w a)) -> w (Base t (w a))
forall b. Base t (w b) -> w (Base t b)
k (Base t (w (w a)) -> w (Base t (w a)))
-> (t -> Base t (w (w a))) -> t -> w (Base t (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> w (w a)) -> Base t t -> Base t (w (w a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w a -> w (w a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate (w a -> w (w a)) -> (t -> w a) -> t -> w (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> w a
c (t -> w a) -> (t -> t) -> t -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Base t b -> Base t b) -> t -> t
forall s t.
(Recursive s, Corecursive t) =>
(forall a. Base s a -> Base t a) -> s -> t
hoist forall b. Base t b -> Base t b
e) (Base t t -> Base t (w (w a)))
-> (t -> Base t t) -> t -> Base t (w (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project

distPara :: Corecursive t => Base t (t, a) -> (t, Base t a)
distPara :: Base t (t, a) -> (t, Base t a)
distPara = (Base t t -> t) -> Base t (t, a) -> (t, Base t a)
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> f (b, a) -> (b, f a)
distZygo Base t t -> t
forall t. Corecursive t => Base t t -> t
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 :: (forall b. Base t (w b) -> w (Base t b))
-> Base t (EnvT t w a) -> EnvT t w (Base t a)
distParaT t :: forall b. Base t (w b) -> w (Base t b)
t = (Base t t -> t)
-> (forall b. Base t (w b) -> w (Base t b))
-> Base t (EnvT t w a)
-> EnvT t w (Base t a)
forall (f :: * -> *) (w :: * -> *) b a.
(Functor f, Comonad w) =>
(f b -> b)
-> (forall c. f (w c) -> w (f c))
-> f (EnvT b w a)
-> EnvT b w (f a)
distZygoT Base t t -> t
forall t. Corecursive t => Base t t -> t
embed forall b. Base t (w b) -> w (Base t b)
t

class Functor (Base t) => Corecursive t where
  embed :: Base t t -> t
#ifdef HAS_GENERIC
  default embed :: (Generic t, Generic (Base t t), GCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t
  embed = Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Rep t Any -> t) -> (Base t t -> Rep t Any) -> Base t t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (Base t t) Any -> Rep t Any
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce (Rep (Base t t) Any -> Rep t Any)
-> (Base t t -> Rep (Base t t) Any) -> Base t t -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base t t -> Rep (Base t t) Any
forall a x. Generic a => a -> Rep a x
from
#endif

  ana
    :: (a -> Base t a) -- ^ a (Base t)-coalgebra
    -> a               -- ^ seed
    -> t               -- ^ resulting fixed point
  ana g :: a -> Base t a
g = a -> t
a where a :: a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t) -> Base t a -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> t
a (Base t a -> Base t t) -> (a -> Base t a) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t a
g

  apo :: (a -> Base t (Either t a)) -> a -> t
  apo g :: a -> Base t (Either t a)
g = a -> t
a where a :: a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either t a -> t) -> Base t (Either t a) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t -> t) -> (a -> t) -> Either t a -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id a -> t
a)) (Base t (Either t a) -> Base t t)
-> (a -> Base t (Either t a)) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t (Either t 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 :: forall b. Base t b -> Base t b
e g :: a -> Base t a
g = a -> t
a where a :: a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t) -> Base t a -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall b. Base t b -> Base t b) -> t -> t
forall s t.
(Recursive s, Corecursive t) =>
(forall a. Base s a -> Base t a) -> s -> t
hoist forall b. Base t b -> Base t b
e (t -> t) -> (a -> t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t
a) (Base t a -> Base t t) -> (a -> Base t a) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t 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 :: forall b. m (Base t b) -> Base t (m b)
k e :: forall b. Base t b -> Base t b
e g :: a -> Base t (m a)
g = m a -> t
a (m a -> t) -> (a -> m a) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return where a :: m a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (m a -> Base t t) -> m a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (m a) -> t) -> Base t (m (m a)) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall b. Base t b -> Base t b) -> t -> t
forall s t.
(Recursive s, Corecursive t) =>
(forall a. Base s a -> Base t a) -> s -> t
hoist forall b. Base t b -> Base t b
e (t -> t) -> (m (m a) -> t) -> m (m a) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> t
a (m a -> t) -> (m (m a) -> m a) -> m (m a) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (Base t (m (m a)) -> Base t t)
-> (m a -> Base t (m (m a))) -> m a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Base t (m a)) -> Base t (m (m a))
forall b. m (Base t b) -> Base t (m b)
k (m (Base t (m a)) -> Base t (m (m a)))
-> (m a -> m (Base t (m a))) -> m a -> Base t (m (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Base t (m a)) -> m a -> m (Base t (m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Base t (m a)
g

hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo :: (f b -> b) -> (a -> f a) -> a -> b
hylo f :: f b -> b
f g :: a -> f a
g = a -> b
h where h :: a -> b
h = f b -> b
f (f b -> b) -> (a -> f b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
h (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
g

fold :: Recursive t => (Base t a -> a) -> t -> a
fold :: (Base t a -> a) -> t -> a
fold = (Base t a -> a) -> t -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata

unfold :: Corecursive t => (a -> Base t a) -> a -> t
unfold :: (a -> Base t a) -> a -> t
unfold = (a -> Base t a) -> a -> t
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana

refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refold :: (f b -> b) -> (a -> f a) -> a -> b
refold = (f b -> b) -> (a -> f a) -> a -> b
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo

-- | Base functor of @[]@.
data ListF a b = Nil | Cons a b
  deriving (ListF a b -> ListF a b -> Bool
(ListF a b -> ListF a b -> Bool)
-> (ListF a b -> ListF a b -> Bool) -> Eq (ListF a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => ListF a b -> ListF a b -> Bool
/= :: ListF a b -> ListF a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => ListF a b -> ListF a b -> Bool
== :: ListF a b -> ListF a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => ListF a b -> ListF a b -> Bool
Eq,Eq (ListF a b)
Eq (ListF a b) =>
(ListF a b -> ListF a b -> Ordering)
-> (ListF a b -> ListF a b -> Bool)
-> (ListF a b -> ListF a b -> Bool)
-> (ListF a b -> ListF a b -> Bool)
-> (ListF a b -> ListF a b -> Bool)
-> (ListF a b -> ListF a b -> ListF a b)
-> (ListF a b -> ListF a b -> ListF a b)
-> Ord (ListF a b)
ListF a b -> ListF a b -> Bool
ListF a b -> ListF a b -> Ordering
ListF a b -> ListF a b -> ListF a b
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. (Ord a, Ord b) => Eq (ListF a b)
forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Bool
forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Ordering
forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> ListF a b
min :: ListF a b -> ListF a b -> ListF a b
$cmin :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> ListF a b
max :: ListF a b -> ListF a b -> ListF a b
$cmax :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> ListF a b
>= :: ListF a b -> ListF a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Bool
> :: ListF a b -> ListF a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Bool
<= :: ListF a b -> ListF a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Bool
< :: ListF a b -> ListF a b -> Bool
$c< :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Bool
compare :: ListF a b -> ListF a b -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => ListF a b -> ListF a b -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (ListF a b)
Ord,Int -> ListF a b -> ShowS
[ListF a b] -> ShowS
ListF a b -> String
(Int -> ListF a b -> ShowS)
-> (ListF a b -> String)
-> ([ListF a b] -> ShowS)
-> Show (ListF a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> ListF a b -> ShowS
forall a b. (Show a, Show b) => [ListF a b] -> ShowS
forall a b. (Show a, Show b) => ListF a b -> String
showList :: [ListF a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [ListF a b] -> ShowS
show :: ListF a b -> String
$cshow :: forall a b. (Show a, Show b) => ListF a b -> String
showsPrec :: Int -> ListF a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> ListF a b -> ShowS
Show,ReadPrec [ListF a b]
ReadPrec (ListF a b)
Int -> ReadS (ListF a b)
ReadS [ListF a b]
(Int -> ReadS (ListF a b))
-> ReadS [ListF a b]
-> ReadPrec (ListF a b)
-> ReadPrec [ListF a b]
-> Read (ListF a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [ListF a b]
forall a b. (Read a, Read b) => ReadPrec (ListF a b)
forall a b. (Read a, Read b) => Int -> ReadS (ListF a b)
forall a b. (Read a, Read b) => ReadS [ListF a b]
readListPrec :: ReadPrec [ListF a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [ListF a b]
readPrec :: ReadPrec (ListF a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (ListF a b)
readList :: ReadS [ListF a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [ListF a b]
readsPrec :: Int -> ReadS (ListF a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (ListF a b)
Read,Typeable
#if HAS_GENERIC
          , (forall x. ListF a b -> Rep (ListF a b) x)
-> (forall x. Rep (ListF a b) x -> ListF a b)
-> Generic (ListF a b)
forall x. Rep (ListF a b) x -> ListF a b
forall x. ListF a b -> Rep (ListF a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (ListF a b) x -> ListF a b
forall a b x. ListF a b -> Rep (ListF a b) x
$cto :: forall a b x. Rep (ListF a b) x -> ListF a b
$cfrom :: forall a b x. ListF a b -> Rep (ListF a b) x
Generic
#endif
#if HAS_GENERIC1
          , (forall a. ListF a a -> Rep1 (ListF a) a)
-> (forall a. Rep1 (ListF a) a -> ListF a a) -> Generic1 (ListF a)
forall a. Rep1 (ListF a) a -> ListF a a
forall a. ListF a a -> Rep1 (ListF a) a
forall a a. Rep1 (ListF a) a -> ListF a a
forall a a. ListF a a -> Rep1 (ListF a) a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall a a. Rep1 (ListF a) a -> ListF a a
$cfrom1 :: forall a a. ListF a a -> Rep1 (ListF a) a
Generic1
#endif
          )

#ifdef LIFTED_FUNCTOR_CLASSES
instance Eq2 ListF where
  liftEq2 :: (a -> b -> Bool)
-> (c -> d -> Bool) -> ListF a c -> ListF b d -> Bool
liftEq2 _ _ Nil        Nil          = Bool
True
  liftEq2 f :: a -> b -> Bool
f g :: c -> d -> Bool
g (Cons a :: a
a b :: c
b) (Cons a' :: b
a' b' :: d
b') = a -> b -> Bool
f a
a b
a' Bool -> Bool -> Bool
&& c -> d -> Bool
g c
b d
b'
  liftEq2 _ _ _          _            = Bool
False

instance Eq a => Eq1 (ListF a) where
  liftEq :: (a -> b -> Bool) -> ListF a a -> ListF a b -> Bool
liftEq = (a -> a -> Bool)
-> (a -> b -> Bool) -> ListF a a -> ListF a b -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance Ord2 ListF where
  liftCompare2 :: (a -> b -> Ordering)
-> (c -> d -> Ordering) -> ListF a c -> ListF b d -> Ordering
liftCompare2 _ _ Nil        Nil          = Ordering
EQ
  liftCompare2 _ _ Nil        _            = Ordering
LT
  liftCompare2 _ _ _          Nil          = Ordering
GT
  liftCompare2 f :: a -> b -> Ordering
f g :: c -> d -> Ordering
g (Cons a :: a
a b :: c
b) (Cons a' :: b
a' b' :: d
b') = a -> b -> Ordering
f a
a b
a' Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` c -> d -> Ordering
g c
b d
b'

instance Ord a => Ord1 (ListF a) where
  liftCompare :: (a -> b -> Ordering) -> ListF a a -> ListF a b -> Ordering
liftCompare = (a -> a -> Ordering)
-> (a -> b -> Ordering) -> ListF a a -> ListF a b -> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

instance Show a => Show1 (ListF a) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> ListF a a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> ListF a a
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance Show2 ListF where
  liftShowsPrec2 :: (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> ListF a b
-> ShowS
liftShowsPrec2 _  _ _  _ _ Nil        = String -> ShowS
showString "Nil"
  liftShowsPrec2 sa :: Int -> a -> ShowS
sa _ sb :: Int -> b -> ShowS
sb _ d :: Int
d (Cons a :: a
a b :: b
b) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString "Cons "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
sa 11 a
a
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b -> ShowS
sb 11 b
b

instance Read2 ListF where
  liftReadsPrec2 :: (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (ListF a b)
liftReadsPrec2 ra :: Int -> ReadS a
ra _ rb :: Int -> ReadS b
rb _ d :: Int
d = Bool -> ReadS (ListF a b) -> ReadS (ListF a b)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ReadS (ListF a b) -> ReadS (ListF a b))
-> ReadS (ListF a b) -> ReadS (ListF a b)
forall a b. (a -> b) -> a -> b
$ \s :: String
s -> ReadS (ListF a b)
forall a b. String -> [(ListF a b, String)]
nil String
s [(ListF a b, String)]
-> [(ListF a b, String)] -> [(ListF a b, String)]
forall a. [a] -> [a] -> [a]
++ ReadS (ListF a b)
cons String
s
    where
      nil :: String -> [(ListF a b, String)]
nil s0 :: String
s0 = do
        ("Nil", s1 :: String
s1) <- ReadS String
lex String
s0
        (ListF a b, String) -> [(ListF a b, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return (ListF a b
forall a b. ListF a b
Nil, String
s1)
      cons :: ReadS (ListF a b)
cons s0 :: String
s0 = do
        ("Cons", s1 :: String
s1) <- ReadS String
lex String
s0
        (a :: a
a,      s2 :: String
s2) <- Int -> ReadS a
ra 11 String
s1
        (b :: b
b,      s3 :: String
s3) <- Int -> ReadS b
rb 11 String
s2
        (ListF a b, String) -> [(ListF a b, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> ListF a b
forall a b. a -> b -> ListF a b
Cons a
a b
b, String
s3)

instance Read a => Read1 (ListF a) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (ListF a a)
liftReadsPrec = (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (ListF a a)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec ReadS [a]
forall a. Read a => ReadS [a]
readList

#else
instance Eq a   => Eq1   (ListF a) where eq1        = (==)
instance Ord a  => Ord1  (ListF a) where compare1   = compare
instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec
instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec
#endif

-- These instances cannot be auto-derived on with GHC <= 7.6
instance Functor (ListF a) where
  fmap :: (a -> b) -> ListF a a -> ListF a b
fmap _ Nil        = ListF a b
forall a b. ListF a b
Nil
  fmap f :: a -> b
f (Cons a :: a
a b :: a
b) = a -> b -> ListF a b
forall a b. a -> b -> ListF a b
Cons a
a (a -> b
f a
b)

instance F.Foldable (ListF a) where
  foldMap :: (a -> m) -> ListF a a -> m
foldMap _ Nil        = m
forall a. Monoid a => a
Data.Monoid.mempty
  foldMap f :: a -> m
f (Cons _ b :: a
b) = a -> m
f a
b

instance T.Traversable (ListF a) where
  traverse :: (a -> f b) -> ListF a a -> f (ListF a b)
traverse _ Nil        = ListF a b -> f (ListF a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ListF a b
forall a b. ListF a b
Nil
  traverse f :: a -> f b
f (Cons a :: a
a b :: a
b) = a -> b -> ListF a b
forall a b. a -> b -> ListF a b
Cons a
a (b -> ListF a b) -> f b -> f (ListF a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
b

instance Bi.Bifunctor ListF where
  bimap :: (a -> b) -> (c -> d) -> ListF a c -> ListF b d
bimap _ _ Nil        = ListF b d
forall a b. ListF a b
Nil
  bimap f :: a -> b
f g :: c -> d
g (Cons a :: a
a b :: c
b) = b -> d -> ListF b d
forall a b. a -> b -> ListF a b
Cons (a -> b
f a
a) (c -> d
g c
b)

instance Bi.Bifoldable ListF where
  bifoldMap :: (a -> m) -> (b -> m) -> ListF a b -> m
bifoldMap _ _ Nil        = m
forall a. Monoid a => a
mempty
  bifoldMap f :: a -> m
f g :: b -> m
g (Cons a :: a
a b :: b
b) = m -> m -> m
forall a. Monoid a => a -> a -> a
mappend (a -> m
f a
a) (b -> m
g b
b)

instance Bi.Bitraversable ListF where
  bitraverse :: (a -> f c) -> (b -> f d) -> ListF a b -> f (ListF c d)
bitraverse _ _ Nil        = ListF c d -> f (ListF c d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ListF c d
forall a b. ListF a b
Nil
  bitraverse f :: a -> f c
f g :: b -> f d
g (Cons a :: a
a b :: b
b) = c -> d -> ListF c d
forall a b. a -> b -> ListF a b
Cons (c -> d -> ListF c d) -> f c -> f (d -> ListF c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a f (d -> ListF c d) -> f d -> f (ListF c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f d
g b
b

type instance Base [a] = ListF a
instance Recursive [a] where
  project :: [a] -> Base [a] [a]
project (x :: a
x:xs :: [a]
xs) = a -> [a] -> ListF a [a]
forall a b. a -> b -> ListF a b
Cons a
x [a]
xs
  project [] = Base [a] [a]
forall a b. ListF a b
Nil

  para :: (Base [a] ([a], a) -> a) -> [a] -> a
para f :: Base [a] ([a], a) -> a
f (x :: a
x:xs :: [a]
xs) = Base [a] ([a], a) -> a
f (a -> ([a], a) -> ListF a ([a], a)
forall a b. a -> b -> ListF a b
Cons a
x ([a]
xs, (Base [a] ([a], a) -> a) -> [a] -> a
forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
para Base [a] ([a], a) -> a
f [a]
xs))
  para f :: Base [a] ([a], a) -> a
f [] = Base [a] ([a], a) -> a
f Base [a] ([a], a)
forall a b. ListF a b
Nil

instance Corecursive [a] where
  embed :: Base [a] [a] -> [a]
embed (Cons x xs) = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs
  embed Nil = []

  apo :: (a -> Base [a] (Either [a] a)) -> a -> [a]
apo f :: a -> Base [a] (Either [a] a)
f a :: a
a = case a -> Base [a] (Either [a] a)
f a
a of
    Cons x (Left xs) -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
    Cons x (Right b) -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Base [a] (Either [a] a)) -> a -> [a]
forall t a. Corecursive t => (a -> Base t (Either t a)) -> a -> t
apo a -> Base [a] (Either [a] a)
f a
b
    Nil -> []

type instance Base (NonEmpty a) = NonEmptyF a
instance Recursive (NonEmpty a) where
  project :: NonEmpty a -> Base (NonEmpty a) (NonEmpty a)
project (x :: a
x:|xs :: [a]
xs) = a -> Maybe (NonEmpty a) -> NonEmptyF a (NonEmpty a)
forall a b. a -> Maybe b -> NonEmptyF a b
NonEmptyF a
x (Maybe (NonEmpty a) -> Base (NonEmpty a) (NonEmpty a))
-> Maybe (NonEmpty a) -> Base (NonEmpty a) (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [a]
xs
instance Corecursive (NonEmpty a) where
  embed :: Base (NonEmpty a) (NonEmpty a) -> NonEmpty a
embed = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a)
-> (NonEmptyF a (NonEmpty a) -> a)
-> NonEmptyF a (NonEmpty a)
-> [a]
-> NonEmpty a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmptyF a (NonEmpty a) -> a
forall a b. NonEmptyF a b -> a
NEF.head (NonEmptyF a (NonEmpty a) -> [a] -> NonEmpty a)
-> (NonEmptyF a (NonEmpty a) -> [a])
-> NonEmptyF a (NonEmpty a)
-> NonEmpty a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([a] -> (NonEmpty a -> [a]) -> Maybe (NonEmpty a) -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
toList (Maybe (NonEmpty a) -> [a])
-> (NonEmptyF a (NonEmpty a) -> Maybe (NonEmpty a))
-> NonEmptyF a (NonEmpty a)
-> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmptyF a (NonEmpty a) -> Maybe (NonEmpty a)
forall a b. NonEmptyF a b -> Maybe b
NEF.tail)

type instance Base Natural = Maybe
instance Recursive Natural where
  project :: Natural -> Base Natural Natural
project 0 = Base Natural Natural
forall a. Maybe a
Nothing
  project n :: Natural
n = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- 1)
instance Corecursive Natural where
  embed :: Base Natural Natural -> Natural
embed = Natural -> (Natural -> Natural) -> Maybe Natural -> Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+1)

-- | Cofree comonads are Recursive/Corecursive
type instance Base (Cofree f a) = CofreeF f a
instance Functor f => Recursive (Cofree f a) where
  project :: Cofree f a -> Base (Cofree f a) (Cofree f a)
project (x :: a
x :< xs :: f (Cofree f a)
xs) = a
x a -> f (Cofree f a) -> CofreeF f a (Cofree f a)
forall (f :: * -> *) a b. a -> f b -> CofreeF f a b
CCTC.:< f (Cofree f a)
xs
instance Functor f => Corecursive (Cofree f a) where
  embed :: Base (Cofree f a) (Cofree f a) -> Cofree f a
embed (x CCTC.:< xs) = a
x a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< f (Cofree f a)
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 :: CofreeT f w a -> Base (CofreeT f w a) (CofreeT f w a)
project = w (CofreeF f a (CofreeT f w a))
-> Compose w (CofreeF f a) (CofreeT f w a)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (w (CofreeF f a (CofreeT f w a))
 -> Compose w (CofreeF f a) (CofreeT f w a))
-> (CofreeT f w a -> w (CofreeF f a (CofreeT f w a)))
-> CofreeT f w a
-> Compose w (CofreeF f a) (CofreeT f w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CofreeT f w a -> w (CofreeF f a (CofreeT f w a))
forall (f :: * -> *) (w :: * -> *) a.
CofreeT f w a -> w (CofreeF f a (CofreeT f w a))
runCofreeT
instance (Functor w, Functor f) => Corecursive (CofreeT f w a) where
  embed :: Base (CofreeT f w a) (CofreeT f w a) -> CofreeT f w a
embed = w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a
forall (f :: * -> *) (w :: * -> *) a.
w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a
CofreeT (w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a)
-> (Compose w (CofreeF f a) (CofreeT f w a)
    -> w (CofreeF f a (CofreeT f w a)))
-> Compose w (CofreeF f a) (CofreeT f w a)
-> CofreeT f w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose w (CofreeF f a) (CofreeT f w a)
-> w (CofreeF f a (CofreeT f w a))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

-- | Free monads are Recursive/Corecursive
type instance Base (Free f a) = FreeF f a

instance Functor f => Recursive (Free f a) where
  project :: Free f a -> Base (Free f a) (Free f a)
project (Pure a :: a
a) = a -> FreeF f a (Free f a)
forall (f :: * -> *) a b. a -> FreeF f a b
CMTF.Pure a
a
  project (Free f :: f (Free f a)
f) = f (Free f a) -> FreeF f a (Free f a)
forall (f :: * -> *) a b. f b -> FreeF f a b
CMTF.Free f (Free f a)
f

improveF :: Functor f => CMFC.F f a -> Free f a
improveF :: F f a -> Free f a
improveF x :: F f a
x = (forall (m :: * -> *). MonadFree f m => m a) -> Free f a
forall (f :: * -> *) a.
Functor f =>
(forall (m :: * -> *). MonadFree f m => m a) -> Free f a
CMFC.improve (F f a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
CMFC.fromF F f a
x)
-- | It may be better to work with the instance for `CMFC.F` directly.
instance Functor f => Corecursive (Free f a) where
  embed :: Base (Free f a) (Free f a) -> Free f a
embed (CMTF.Pure a) = a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure a
a
  embed (CMTF.Free f) = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free f (Free f a)
f
  ana :: (a -> Base (Free f a) a) -> a -> Free f a
ana               coalg :: a -> Base (Free f a) a
coalg = F f a -> Free f a
forall (f :: * -> *) a. Functor f => F f a -> Free f a
improveF (F f a -> Free f a) -> (a -> F f a) -> a -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Base (F f a) a) -> a -> F f a
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana               a -> Base (F f a) a
a -> Base (Free f a) a
coalg
  postpro :: (forall b. Base (Free f a) b -> Base (Free f a) b)
-> (a -> Base (Free f a) a) -> a -> Free f a
postpro       nat :: forall b. Base (Free f a) b -> Base (Free f a) b
nat coalg :: a -> Base (Free f a) a
coalg = F f a -> Free f a
forall (f :: * -> *) a. Functor f => F f a -> Free f a
improveF (F f a -> Free f a) -> (a -> F f a) -> a -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Base (F f a) b -> Base (F f a) b)
-> (a -> Base (F f a) a) -> a -> F f a
forall t a.
(Corecursive t, Recursive t) =>
(forall b. Base t b -> Base t b) -> (a -> Base t a) -> a -> t
postpro       forall b. Base (F f a) b -> Base (F f a) b
forall b. Base (Free f a) b -> Base (Free f a) b
nat a -> Base (F f a) a
a -> Base (Free f a) a
coalg
  gpostpro :: (forall b. m (Base (Free f a) b) -> Base (Free f a) (m b))
-> (forall b. Base (Free f a) b -> Base (Free f a) b)
-> (a -> Base (Free f a) (m a))
-> a
-> Free f a
gpostpro dist :: forall b. m (Base (Free f a) b) -> Base (Free f a) (m b)
dist nat :: forall b. Base (Free f a) b -> Base (Free f a) b
nat coalg :: a -> Base (Free f a) (m a)
coalg = F f a -> Free f a
forall (f :: * -> *) a. Functor f => F f a -> Free f a
improveF (F f a -> Free f a) -> (a -> F f a) -> a -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. m (Base (F f a) b) -> Base (F f a) (m b))
-> (forall b. Base (F f a) b -> Base (F f a) b)
-> (a -> Base (F f a) (m a))
-> a
-> F f a
forall t (m :: * -> *) a.
(Corecursive t, Recursive t, Monad m) =>
(forall b. m (Base t b) -> Base t (m b))
-> (forall b. Base t b -> Base t b)
-> (a -> Base t (m a))
-> a
-> t
gpostpro forall b. m (Base (F f a) b) -> Base (F f a) (m b)
forall b. m (Base (Free f a) b) -> Base (Free f a) (m b)
dist forall b. Base (F f a) b -> Base (F f a) b
forall b. Base (Free f a) b -> Base (Free f a) b
nat a -> Base (F f a) (m a)
a -> Base (Free f a) (m a)
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 :: FreeT f m a -> Base (FreeT f m a) (FreeT f m a)
project = m (FreeF f a (FreeT f m a)) -> Compose m (FreeF f a) (FreeT f m a)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (m (FreeF f a (FreeT f m a))
 -> Compose m (FreeF f a) (FreeT f m a))
-> (FreeT f m a -> m (FreeF f a (FreeT f m a)))
-> FreeT f m a
-> Compose m (FreeF f a) (FreeT f m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m a -> m (FreeF f a (FreeT f m a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT
instance (Functor m, Functor f) => Corecursive (FreeT f m a) where
  embed :: Base (FreeT f m a) (FreeT f m a) -> FreeT f m a
embed = m (FreeF f a (FreeT f m a)) -> FreeT f m a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f a (FreeT f m a)) -> FreeT f m a)
-> (Compose m (FreeF f a) (FreeT f m a)
    -> m (FreeF f a (FreeT f m a)))
-> Compose m (FreeF f a) (FreeT f m a)
-> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose m (FreeF f a) (FreeT f m a) -> m (FreeF f a (FreeT f m a))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
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 :: Maybe a -> Base (Maybe a) (Maybe a)
project = Maybe a -> Base (Maybe a) (Maybe a)
forall k a (b :: k). a -> Const a b
Const
instance Corecursive (Maybe a) where embed :: Base (Maybe a) (Maybe a) -> Maybe a
embed = Base (Maybe a) (Maybe a) -> Maybe a
forall a k (b :: k). Const a b -> a
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 :: Either a b -> Base (Either a b) (Either a b)
project = Either a b -> Base (Either a b) (Either a b)
forall k a (b :: k). a -> Const a b
Const
instance Corecursive (Either a b) where embed :: Base (Either a b) (Either a b) -> Either a b
embed = Base (Either a b) (Either a b) -> Either a b
forall a k (b :: k). Const a b -> a
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 :: (forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gcata k :: forall b. Base t (w b) -> w (Base t b)
k g :: Base t (w a) -> a
g = Base t (w a) -> a
g (Base t (w a) -> a) -> (t -> Base t (w a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (Base t (w a)) -> Base t (w a)
forall (w :: * -> *) a. Comonad w => w a -> a
extract (w (Base t (w a)) -> Base t (w a))
-> (t -> w (Base t (w a))) -> t -> Base t (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> w (Base t (w a))
c where
  c :: t -> w (Base t (w a))
c = Base t (w (w a)) -> w (Base t (w a))
forall b. Base t (w b) -> w (Base t b)
k (Base t (w (w a)) -> w (Base t (w a)))
-> (t -> Base t (w (w a))) -> t -> w (Base t (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> w (w a)) -> Base t t -> Base t (w (w a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w a -> w (w a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate (w a -> w (w a)) -> (t -> w a) -> t -> w (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (w a) -> a) -> w (Base t (w a)) -> w a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t (w a) -> a
g (w (Base t (w a)) -> w a) -> (t -> w (Base t (w a))) -> t -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> w (Base t (w a))
c) (Base t t -> Base t (w (w a)))
-> (t -> Base t t) -> t -> Base t (w (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project
gfold :: (forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gfold k :: forall b. Base t (w b) -> w (Base t b)
k g :: Base t (w a) -> a
g t :: t
t = (forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
forall t (w :: * -> *) a.
(Recursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gcata forall b. Base t (w b) -> w (Base t b)
k Base t (w a) -> a
g t
t

distCata :: Functor f => f (Identity a) -> Identity (f a)
distCata :: f (Identity a) -> Identity (f a)
distCata = f a -> Identity (f a)
forall a. a -> Identity a
Identity (f a -> Identity (f a))
-> (f (Identity a) -> f a) -> f (Identity a) -> Identity (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity a -> a) -> f (Identity a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity a -> a
forall a. Identity a -> a
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 :: (forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gana k :: forall b. m (Base t b) -> Base t (m b)
k f :: a -> Base t (m a)
f = m (Base t (m a)) -> t
a (m (Base t (m a)) -> t) -> (a -> m (Base t (m a))) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base t (m a) -> m (Base t (m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Base t (m a) -> m (Base t (m a)))
-> (a -> Base t (m a)) -> a -> m (Base t (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t (m a)
f where
  a :: m (Base t (m a)) -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t)
-> (m (Base t (m a)) -> Base t t) -> m (Base t (m a)) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (m a) -> t) -> Base t (m (m a)) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m (Base t (m a)) -> t
a (m (Base t (m a)) -> t)
-> (m (m a) -> m (Base t (m a))) -> m (m a) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Base t (m a)) -> m a -> m (Base t (m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Base t (m a)
f (m a -> m (Base t (m a)))
-> (m (m a) -> m a) -> m (m a) -> m (Base t (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (Base t (m (m a)) -> Base t t)
-> (m (Base t (m a)) -> Base t (m (m a)))
-> m (Base t (m a))
-> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Base t (m a)) -> Base t (m (m a))
forall b. m (Base t b) -> Base t (m b)
k
gunfold :: (forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gunfold k :: forall b. m (Base t b) -> Base t (m b)
k f :: a -> Base t (m a)
f t :: a
t = (forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
forall t (m :: * -> *) a.
(Corecursive t, Monad m) =>
(forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gana forall b. m (Base t b) -> Base t (m b)
k a -> Base t (m a)
f a
t

distAna :: Functor f => Identity (f a) -> f (Identity a)
distAna :: Identity (f a) -> f (Identity a)
distAna = (a -> Identity a) -> f a -> f (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity (f a -> f (Identity a))
-> (Identity (f a) -> f a) -> Identity (f a) -> f (Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (f a) -> f a
forall a. Identity a -> a
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 :: (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 :: forall c. f (w c) -> w (f c)
w m :: forall d. m (f d) -> f (m d)
m f :: f (w b) -> b
f g :: a -> f (m a)
g = w b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract (w b -> b) -> (a -> w b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> w b
h (m a -> w b) -> (a -> m a) -> a -> w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return where
  h :: m a -> w b
h = (f (w b) -> b) -> w (f (w b)) -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (w b) -> b
f (w (f (w b)) -> w b) -> (m a -> w (f (w b))) -> m a -> w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (w (w b)) -> w (f (w b))
forall c. f (w c) -> w (f c)
w (f (w (w b)) -> w (f (w b)))
-> (m a -> f (w (w b))) -> m a -> w (f (w b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (m a) -> w (w b)) -> f (m (m a)) -> f (w (w b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w b -> w (w b)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate (w b -> w (w b)) -> (m (m a) -> w b) -> m (m a) -> w (w b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> w b
h (m a -> w b) -> (m (m a) -> m a) -> m (m a) -> w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (f (m (m a)) -> f (w (w b)))
-> (m a -> f (m (m a))) -> m a -> f (w (w b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (f (m a)) -> f (m (m a))
forall d. m (f d) -> f (m d)
m (m (f (m a)) -> f (m (m a)))
-> (m a -> m (f (m a))) -> m a -> f (m (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (m a)) -> m a -> m (f (m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> f (m a)
g
grefold :: (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
grefold w :: forall c. f (w c) -> w (f c)
w m :: forall d. m (f d) -> f (m d)
m f :: f (w b) -> b
f g :: a -> f (m a)
g a :: a
a = (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
forall (w :: * -> *) (f :: * -> *) (m :: * -> *) b a.
(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 forall c. f (w c) -> w (f c)
w forall d. m (f d) -> f (m d)
m f (w b) -> b
f a -> f (m a)
g a
a

futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t
futu :: (a -> Base t (Free (Base t) a)) -> a -> t
futu = (forall b. Free (Base t) (Base t b) -> Base t (Free (Base t) b))
-> (a -> Base t (Free (Base t) a)) -> a -> t
forall t (m :: * -> *) a.
(Corecursive t, Monad m) =>
(forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gana forall b. Free (Base t) (Base t b) -> Base t (Free (Base t) b)
forall (f :: * -> *) a. Functor f => Free f (f a) -> f (Free f a)
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 :: (forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (FreeT (Base t) m a)) -> a -> t
gfutu g :: forall b. m (Base t b) -> Base t (m b)
g = (forall b.
 FreeT (Base t) m (Base t b) -> Base t (FreeT (Base t) m b))
-> (a -> Base t (FreeT (Base t) m a)) -> a -> t
forall t (m :: * -> *) a.
(Corecursive t, Monad m) =>
(forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gana ((forall b. m (Base t b) -> Base t (m b))
-> FreeT (Base t) m (Base t b) -> Base t (FreeT (Base t) m b)
forall (f :: * -> *) (h :: * -> *) a.
(Functor f, Functor h) =>
(forall b. h (f b) -> f (h b))
-> FreeT f h (f a) -> f (FreeT f h a)
distGFutu forall b. m (Base t b) -> Base t (m b)
g)

distFutu :: Functor f => Free f (f a) -> f (Free f a)
distFutu :: Free f (f a) -> f (Free f a)
distFutu (Pure fx :: f a
fx) = a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure (a -> Free f a) -> f a -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
fx
distFutu (Free ff :: f (Free f (f a))
ff) = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f a) -> Free f a)
-> (Free f (f a) -> f (Free f a)) -> Free f (f a) -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free f (f a) -> f (Free f a)
forall (f :: * -> *) a. Functor f => Free f (f a) -> f (Free f a)
distFutu (Free f (f a) -> Free f a) -> f (Free f (f a)) -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f (f a))
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 :: (forall b. h (f b) -> f (h b))
-> FreeT f h (f a) -> f (FreeT f h a)
distGFutu k :: forall b. h (f b) -> f (h b)
k = FreeT f h (f a) -> f (FreeT f h a)
d where
  d :: FreeT f h (f a) -> f (FreeT f h a)
d = (h (FreeF f a (FreeT f h a)) -> FreeT f h a)
-> f (h (FreeF f a (FreeT f h a))) -> f (FreeT f h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h (FreeF f a (FreeT f h a)) -> FreeT f h a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (f (h (FreeF f a (FreeT f h a))) -> f (FreeT f h a))
-> (FreeT f h (f a) -> f (h (FreeF f a (FreeT f h a))))
-> FreeT f h (f a)
-> f (FreeT f h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h (f (FreeF f a (FreeT f h a))) -> f (h (FreeF f a (FreeT f h a)))
forall b. h (f b) -> f (h b)
k (h (f (FreeF f a (FreeT f h a)))
 -> f (h (FreeF f a (FreeT f h a))))
-> (FreeT f h (f a) -> h (f (FreeF f a (FreeT f h a))))
-> FreeT f h (f a)
-> f (h (FreeF f a (FreeT f h a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeF f (f a) (FreeT f h (f a)) -> f (FreeF f a (FreeT f h a)))
-> h (FreeF f (f a) (FreeT f h (f a)))
-> h (f (FreeF f a (FreeT f h a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeF f (f a) (FreeT f h (f a)) -> f (FreeF f a (FreeT f h a))
d' (h (FreeF f (f a) (FreeT f h (f a)))
 -> h (f (FreeF f a (FreeT f h a))))
-> (FreeT f h (f a) -> h (FreeF f (f a) (FreeT f h (f a))))
-> FreeT f h (f a)
-> h (f (FreeF f a (FreeT f h a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f h (f a) -> h (FreeF f (f a) (FreeT f h (f a)))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT
  d' :: FreeF f (f a) (FreeT f h (f a)) -> f (FreeF f a (FreeT f h a))
d' (CMTF.Pure ff :: f a
ff) = a -> FreeF f a (FreeT f h a)
forall (f :: * -> *) a b. a -> FreeF f a b
CMTF.Pure (a -> FreeF f a (FreeT f h a))
-> f a -> f (FreeF f a (FreeT f h a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
ff
  d' (CMTF.Free ff :: f (FreeT f h (f a))
ff) = f (FreeT f h a) -> FreeF f a (FreeT f h a)
forall (f :: * -> *) a b. f b -> FreeF f a b
CMTF.Free (f (FreeT f h a) -> FreeF f a (FreeT f h a))
-> (FreeT f h (f a) -> f (FreeT f h a))
-> FreeT f h (f a)
-> FreeF f a (FreeT f h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f h (f a) -> f (FreeT f h a)
d (FreeT f h (f a) -> FreeF f a (FreeT f h a))
-> f (FreeT f h (f a)) -> f (FreeF f a (FreeT f h a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (FreeT f h (f a))
ff

-------------------------------------------------------------------------------
-- Fix
-------------------------------------------------------------------------------

newtype Fix f = Fix (f (Fix f))

unfix :: Fix f -> f (Fix f)
unfix :: Fix f -> f (Fix f)
unfix (Fix f :: f (Fix f)
f) = f (Fix f)
f

instance Eq1 f => Eq (Fix f) where
  Fix a :: f (Fix f)
a == :: Fix f -> Fix f -> Bool
== Fix b :: f (Fix f)
b = f (Fix f) -> f (Fix f) -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 f (Fix f)
a f (Fix f)
b

instance Ord1 f => Ord (Fix f) where
  compare :: Fix f -> Fix f -> Ordering
compare (Fix a :: f (Fix f)
a) (Fix b :: f (Fix f)
b) = f (Fix f) -> f (Fix f) -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 f (Fix f)
a f (Fix f)
b

instance Show1 f => Show (Fix f) where
  showsPrec :: Int -> Fix f -> ShowS
showsPrec d :: Int
d (Fix a :: f (Fix f)
a) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 11)
      (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString "Fix "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f (Fix f) -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 11 f (Fix f)
a

instance Read1 f => Read (Fix f) where
  readPrec :: ReadPrec (Fix f)
readPrec = ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Fix f) -> ReadPrec (Fix f))
-> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec 10 (ReadPrec (Fix f) -> ReadPrec (Fix f))
-> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a b. (a -> b) -> a -> b
$ do
    Ident "Fix" <- ReadPrec Lexeme
lexP
    f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> ReadPrec (f (Fix f)) -> ReadPrec (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (f (Fix f)) -> ReadPrec (f (Fix f))
forall a. ReadPrec a -> ReadPrec a
step ((Int -> ReadS (f (Fix f))) -> ReadPrec (f (Fix f))
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec Int -> ReadS (f (Fix f))
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1)

#ifdef __GLASGOW_HASKELL__
#if HAS_POLY_TYPEABLE
deriving instance Typeable Fix
deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)
#else
instance Typeable1 f => Typeable (Fix f) where
   typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]
     where asArgsTypeOf :: f a -> Fix f -> f a
           asArgsTypeOf = const

fixTyCon :: TyCon
#if MIN_VERSION_base(4,4,0)
fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"
#else
fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"
#endif
{-# NOINLINE fixTyCon #-}

instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where
  gfoldl f z (Fix a) = z Fix `f` a
  toConstr _ = fixConstr
  gunfold k z c = case constrIndex c of
    1 -> k (z (Fix))
    _ -> error "gunfold"
  dataTypeOf _ = fixDataType

fixConstr :: Constr
fixConstr = mkConstr fixDataType "Fix" [] Prefix

fixDataType :: DataType
fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]
#endif
#endif

type instance Base (Fix f) = f
instance Functor f => Recursive (Fix f) where
  project :: Fix f -> Base (Fix f) (Fix f)
project (Fix a :: f (Fix f)
a) = f (Fix f)
Base (Fix f) (Fix f)
a
instance Functor f => Corecursive (Fix f) where
  embed :: Base (Fix f) (Fix f) -> Fix f
embed = Base (Fix f) (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

hoist :: (Recursive s, Corecursive t)
      => (forall a. Base s a -> Base t a) -> s -> t
hoist :: (forall a. Base s a -> Base t a) -> s -> t
hoist n :: forall a. Base s a -> Base t a
n = (Base s t -> t) -> s -> t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata (Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (Base s t -> Base t t) -> Base s t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base s t -> Base t t
forall a. Base s a -> Base t a
n)

refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix :: s -> t
refix = (Base s t -> t) -> s -> t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base s t -> t
forall t. Corecursive t => Base t t -> t
embed

toFix :: Recursive t => t -> Fix (Base t)
toFix :: t -> Fix (Base t)
toFix = t -> Fix (Base t)
forall s t. (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix

fromFix :: Corecursive t => Fix (Base t) -> t
fromFix :: Fix (Base t) -> t
fromFix = Fix (Base t) -> t
forall s t. (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix


-------------------------------------------------------------------------------
-- Lambek
-------------------------------------------------------------------------------

-- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed'
lambek :: (Recursive t, Corecursive t) => (t -> Base t t)
lambek :: t -> Base t t
lambek = (Base t (Base t t) -> Base t t) -> t -> Base t t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata ((Base t t -> t) -> Base t (Base t t) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t t -> t
forall t. Corecursive t => Base t t -> t
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 :: Base t t -> t
colambek = (Base t t -> Base t (Base t t)) -> Base t t -> t
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana ((t -> Base t t) -> Base t t -> Base t (Base t t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> Base t t
forall t. Recursive t => t -> Base t t
project)

newtype Mu f = Mu (forall a. (f a -> a) -> a)
type instance Base (Mu f) = f
instance Functor f => Recursive (Mu f) where
  project :: Mu f -> Base (Mu f) (Mu f)
project = Mu f -> Base (Mu f) (Mu f)
forall t. (Recursive t, Corecursive t) => t -> Base t t
lambek
  cata :: (Base (Mu f) a -> a) -> Mu f -> a
cata f :: Base (Mu f) a -> a
f (Mu g :: forall a. (f a -> a) -> a
g) = (f a -> a) -> a
forall a. (f a -> a) -> a
g f a -> a
Base (Mu f) a -> a
f
instance Functor f => Corecursive (Mu f) where
  embed :: Base (Mu f) (Mu f) -> Mu f
embed m :: Base (Mu f) (Mu f)
m = (forall a. (f a -> a) -> a) -> Mu f
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu (\f :: f a -> a
f -> f a -> a
f ((Mu f -> a) -> f (Mu f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Base (Mu f) a -> a) -> Mu f -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
fold f a -> a
Base (Mu f) a -> a
f) f (Mu f)
Base (Mu f) (Mu f)
m))

instance (Functor f, Eq1 f) => Eq (Mu f) where
  == :: Mu f -> Mu f -> Bool
(==) = Fix f -> Fix f -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Fix f -> Fix f -> Bool) -> (Mu f -> Fix f) -> Mu f -> Mu f -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Mu f -> Fix f
forall t. Recursive t => t -> Fix (Base t)
toFix

instance (Functor f, Ord1 f) => Ord (Mu f) where
  compare :: Mu f -> Mu f -> Ordering
compare = Fix f -> Fix f -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Fix f -> Fix f -> Ordering)
-> (Mu f -> Fix f) -> Mu f -> Mu f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Mu f -> Fix f
forall t. Recursive t => t -> Fix (Base t)
toFix

instance (Functor f, Show1 f) => Show (Mu f) where
  showsPrec :: Int -> Mu f -> ShowS
showsPrec d :: Int
d f :: Mu f
f = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString "fromFix " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix f -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 (Mu f -> Fix (Base (Mu f))
forall t. Recursive t => t -> Fix (Base t)
toFix Mu f
f)

#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 f) => Read (Mu f) where
  readPrec :: ReadPrec (Mu f)
readPrec = ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Mu f) -> ReadPrec (Mu f))
-> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec 10 (ReadPrec (Mu f) -> ReadPrec (Mu f))
-> ReadPrec (Mu f) -> ReadPrec (Mu f)
forall a b. (a -> b) -> a -> b
$ do
    Ident "fromFix" <- ReadPrec Lexeme
lexP
    Fix f -> Mu f
forall t. Corecursive t => Fix (Base t) -> t
fromFix (Fix f -> Mu f) -> ReadPrec (Fix f) -> ReadPrec (Mu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
step ReadPrec (Fix f)
forall a. Read a => ReadPrec a
readPrec
#endif

-- | A specialized, faster version of 'hoist' for 'Mu'.
hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu n :: forall a. f a -> g a
n (Mu mk :: forall a. (f a -> a) -> a
mk) = (forall a. (g a -> a) -> a) -> Mu g
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu ((forall a. (g a -> a) -> a) -> Mu g)
-> (forall a. (g a -> a) -> a) -> Mu g
forall a b. (a -> b) -> a -> b
$ \roll :: g a -> a
roll -> (f a -> a) -> a
forall a. (f a -> a) -> a
mk (g a -> a
roll (g a -> a) -> (f a -> g a) -> f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a
forall a. f a -> g a
n)


-- | Church encoded free monads are Recursive/Corecursive, in the same way that
-- 'Mu' is.
type instance Base (CMFC.F f a) = FreeF f a
cmfcCata :: (a -> r) -> (f r -> r) -> CMFC.F f a -> r
cmfcCata :: (a -> r) -> (f r -> r) -> F f a -> r
cmfcCata p :: a -> r
p f :: f r -> r
f (CMFC.F run :: forall r. (a -> r) -> (f r -> r) -> r
run) = (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
run a -> r
p f r -> r
f
instance Functor f => Recursive (CMFC.F f a) where
  project :: F f a -> Base (F f a) (F f a)
project = F f a -> Base (F f a) (F f a)
forall t. (Recursive t, Corecursive t) => t -> Base t t
lambek
  cata :: (Base (F f a) a -> a) -> F f a -> a
cata f :: Base (F f a) a -> a
f = (a -> a) -> (f a -> a) -> F f a -> a
forall a r (f :: * -> *). (a -> r) -> (f r -> r) -> F f a -> r
cmfcCata (FreeF f a a -> a
Base (F f a) a -> a
f (FreeF f a a -> a) -> (a -> FreeF f a a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FreeF f a a
forall (f :: * -> *) a b. a -> FreeF f a b
CMTF.Pure) (FreeF f a a -> a
Base (F f a) a -> a
f (FreeF f a a -> a) -> (f a -> FreeF f a a) -> f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> FreeF f a a
forall (f :: * -> *) a b. f b -> FreeF f a b
CMTF.Free)
instance Functor f => Corecursive (CMFC.F f a) where
  embed :: Base (F f a) (F f a) -> F f a
embed (CMTF.Pure a)  = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
CMFC.F ((forall r. (a -> r) -> (f r -> r) -> r) -> F f a)
-> (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall a b. (a -> b) -> a -> b
$ \p :: a -> r
p _ -> a -> r
p a
a
  embed (CMTF.Free fr) = (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
CMFC.F ((forall r. (a -> r) -> (f r -> r) -> r) -> F f a)
-> (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
forall a b. (a -> b) -> a -> b
$ \p :: a -> r
p f :: f r -> r
f -> f r -> r
f (f r -> r) -> f r -> r
forall a b. (a -> b) -> a -> b
$ (F f a -> r) -> f (F f a) -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> r) -> (f r -> r) -> F f a -> r
forall a r (f :: * -> *). (a -> r) -> (f r -> r) -> F f a -> r
cmfcCata a -> r
p f r -> r
f) f (F f a)
fr


data Nu f where Nu :: (a -> f a) -> a -> Nu f
type instance Base (Nu f) = f
instance Functor f => Corecursive (Nu f) where
  embed :: Base (Nu f) (Nu f) -> Nu f
embed = Base (Nu f) (Nu f) -> Nu f
forall t. (Recursive t, Corecursive t) => Base t t -> t
colambek
  ana :: (a -> Base (Nu f) a) -> a -> Nu f
ana = (a -> Base (Nu f) a) -> a -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
Nu
instance Functor f => Recursive (Nu f) where
  project :: Nu f -> Base (Nu f) (Nu f)
project (Nu f :: a -> f a
f a :: a
a) = (a -> f a) -> a -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
Nu a -> f a
f (a -> Nu f) -> f a -> f (Nu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
a

instance (Functor f, Eq1 f) => Eq (Nu f) where
  == :: Nu f -> Nu f -> Bool
(==) = Fix f -> Fix f -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Fix f -> Fix f -> Bool) -> (Nu f -> Fix f) -> Nu f -> Nu f -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Nu f -> Fix f
forall t. Recursive t => t -> Fix (Base t)
toFix

instance (Functor f, Ord1 f) => Ord (Nu f) where
  compare :: Nu f -> Nu f -> Ordering
compare = Fix f -> Fix f -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Fix f -> Fix f -> Ordering)
-> (Nu f -> Fix f) -> Nu f -> Nu f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Nu f -> Fix f
forall t. Recursive t => t -> Fix (Base t)
toFix

instance (Functor f, Show1 f) => Show (Nu f) where
  showsPrec :: Int -> Nu f -> ShowS
showsPrec d :: Int
d f :: Nu f
f = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString "fromFix " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix f -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 (Nu f -> Fix (Base (Nu f))
forall t. Recursive t => t -> Fix (Base t)
toFix Nu f
f)

#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 f) => Read (Nu f) where
  readPrec :: ReadPrec (Nu f)
readPrec = ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (Nu f) -> ReadPrec (Nu f))
-> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a. Int -> ReadPrec a -> ReadPrec a
prec 10 (ReadPrec (Nu f) -> ReadPrec (Nu f))
-> ReadPrec (Nu f) -> ReadPrec (Nu f)
forall a b. (a -> b) -> a -> b
$ do
    Ident "fromFix" <- ReadPrec Lexeme
lexP
    Fix f -> Nu f
forall t. Corecursive t => Fix (Base t) -> t
fromFix (Fix f -> Nu f) -> ReadPrec (Fix f) -> ReadPrec (Nu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (Fix f) -> ReadPrec (Fix f)
forall a. ReadPrec a -> ReadPrec a
step ReadPrec (Fix f)
forall a. Read a => ReadPrec a
readPrec
#endif

-- | A specialized, faster version of 'hoist' for 'Nu'.
hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu n :: forall a. f a -> g a
n (Nu next :: a -> f a
next seed :: a
seed) = (a -> g a) -> a -> Nu g
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
Nu (f a -> g a
forall a. f a -> g a
n (f a -> g a) -> (a -> f a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
next) a
seed


zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo :: (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo f :: Base t b -> b
f = (forall b. Base t (b, b) -> (b, Base t b))
-> (Base t (b, a) -> a) -> t -> a
forall t (w :: * -> *) a.
(Recursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gfold ((Base t b -> b) -> Base t (b, b) -> (b, Base t b)
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> f (b, a) -> (b, f a)
distZygo Base t b -> b
f)

distZygo
  :: Functor f
  => (f b -> b)             -- An f-algebra
  -> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion
distZygo :: (f b -> b) -> f (b, a) -> (b, f a)
distZygo g :: f b -> b
g m :: f (b, a)
m = (f b -> b
g (((b, a) -> b) -> f (b, a) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst f (b, a)
m), ((b, a) -> a) -> f (b, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> a
forall a b. (a, b) -> b
snd f (b, a)
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 :: (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 :: Base t b -> b
f w :: forall c. Base t (w c) -> w (Base t c)
w = (forall b. Base t (EnvT b w b) -> EnvT b w (Base t b))
-> (Base t (EnvT b w a) -> a) -> t -> a
forall t (w :: * -> *) a.
(Recursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gfold ((Base t b -> b)
-> (forall c. Base t (w c) -> w (Base t c))
-> Base t (EnvT b w b)
-> EnvT b w (Base t b)
forall (f :: * -> *) (w :: * -> *) b a.
(Functor f, Comonad w) =>
(f b -> b)
-> (forall c. f (w c) -> w (f c))
-> f (EnvT b w a)
-> EnvT b w (f a)
distZygoT Base t b -> b
f forall c. Base t (w c) -> w (Base t c)
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 :: (f b -> b)
-> (forall c. f (w c) -> w (f c))
-> f (EnvT b w a)
-> EnvT b w (f a)
distZygoT g :: f b -> b
g k :: forall c. f (w c) -> w (f c)
k fe :: f (EnvT b w a)
fe = b -> w (f a) -> EnvT b w (f a)
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (f b -> b
g (EnvT b w a -> b
forall e (w :: * -> *) a. EnvT e w a -> e
getEnv (EnvT b w a -> b) -> f (EnvT b w a) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (EnvT b w a)
fe)) (f (w a) -> w (f a)
forall c. f (w c) -> w (f c)
k (EnvT b w a -> w a
forall (t :: (* -> *) -> * -> *) (w :: * -> *) a.
(ComonadTrans t, Comonad w) =>
t w a -> w a
lower (EnvT b w a -> w a) -> f (EnvT b w a) -> f (w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (EnvT b w a)
fe))
  where getEnv :: EnvT e w a -> e
getEnv (EnvT e :: e
e _) = e
e

gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t
gapo :: (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t
gapo g :: b -> Base t b
g = (forall b. Either b (Base t b) -> Base t (Either b b))
-> (a -> Base t (Either b a)) -> a -> t
forall t (m :: * -> *) a.
(Corecursive t, Monad m) =>
(forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a)) -> a -> t
gunfold ((b -> Base t b) -> Either b (Base t b) -> Base t (Either b b)
forall (f :: * -> *) b a.
Functor f =>
(b -> f b) -> Either b (f a) -> f (Either b a)
distGApo b -> Base t b
g)

distApo :: Recursive t => Either t (Base t a) -> Base t (Either t a)
distApo :: Either t (Base t a) -> Base t (Either t a)
distApo = (t -> Base t t) -> Either t (Base t a) -> Base t (Either t a)
forall (f :: * -> *) b a.
Functor f =>
(b -> f b) -> Either b (f a) -> f (Either b a)
distGApo t -> Base t t
forall t. Recursive t => t -> Base t t
project

distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a)
distGApo :: (b -> f b) -> Either b (f a) -> f (Either b a)
distGApo f :: b -> f b
f = (b -> f (Either b a))
-> (f a -> f (Either b a)) -> Either b (f a) -> f (Either b a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either b a) -> f b -> f (Either b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either b a
forall a b. a -> Either a b
Left (f b -> f (Either b a)) -> (b -> f b) -> b -> f (Either b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> f b
f) ((a -> Either b a) -> f a -> f (Either b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either b a
forall a b. b -> Either a b
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 :: (b -> f b)
-> (forall c. m (f c) -> f (m c))
-> ExceptT b m (f a)
-> f (ExceptT b m a)
distGApoT g :: b -> f b
g k :: forall c. m (f c) -> f (m c)
k = (m (Either b a) -> ExceptT b m a)
-> f (m (Either b a)) -> f (ExceptT b m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (Either b a) -> ExceptT b m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (f (m (Either b a)) -> f (ExceptT b m a))
-> (ExceptT b m (f a) -> f (m (Either b a)))
-> ExceptT b m (f a)
-> f (ExceptT b m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (f (Either b a)) -> f (m (Either b a))
forall c. m (f c) -> f (m c)
k (m (f (Either b a)) -> f (m (Either b a)))
-> (ExceptT b m (f a) -> m (f (Either b a)))
-> ExceptT b m (f a)
-> f (m (Either b a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either b (f a) -> f (Either b a))
-> m (Either b (f a)) -> m (f (Either b a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> f b) -> Either b (f a) -> f (Either b a)
forall (f :: * -> *) b a.
Functor f =>
(b -> f b) -> Either b (f a) -> f (Either b a)
distGApo b -> f b
g) (m (Either b (f a)) -> m (f (Either b a)))
-> (ExceptT b m (f a) -> m (Either b (f a)))
-> ExceptT b m (f a)
-> m (f (Either b a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT b m (f a) -> m (Either b (f a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

-- | Course-of-value iteration
histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a
histo :: (Base t (Cofree (Base t) a) -> a) -> t -> a
histo = (forall b.
 Base t (Cofree (Base t) b) -> Cofree (Base t) (Base t b))
-> (Base t (Cofree (Base t) a) -> a) -> t -> a
forall t (w :: * -> *) a.
(Recursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gcata forall b. Base t (Cofree (Base t) b) -> Cofree (Base t) (Base t b)
forall (f :: * -> *) a.
Functor f =>
f (Cofree f a) -> Cofree f (f a)
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 :: (forall b. Base t (w b) -> w (Base t b))
-> (Base t (CofreeT (Base t) w a) -> a) -> t -> a
ghisto g :: forall b. Base t (w b) -> w (Base t b)
g = (forall b.
 Base t (CofreeT (Base t) w b) -> CofreeT (Base t) w (Base t b))
-> (Base t (CofreeT (Base t) w a) -> a) -> t -> a
forall t (w :: * -> *) a.
(Recursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a) -> t -> a
gcata ((forall b. Base t (w b) -> w (Base t b))
-> Base t (CofreeT (Base t) w b) -> CofreeT (Base t) w (Base t b)
forall (f :: * -> *) (h :: * -> *) a.
(Functor f, Functor h) =>
(forall b. f (h b) -> h (f b))
-> f (CofreeT f h a) -> CofreeT f h (f a)
distGHisto forall b. Base t (w b) -> w (Base t b)
g)

distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a)
distHisto :: f (Cofree f a) -> Cofree f (f a)
distHisto fc :: f (Cofree f a)
fc = (Cofree f a -> a) -> f (Cofree f a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree f a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f (Cofree f a)
fc f a -> f (Cofree f (f a)) -> Cofree f (f a)
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< (Cofree f a -> Cofree f (f a))
-> f (Cofree f a) -> f (Cofree f (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f (Cofree f a) -> Cofree f (f a)
forall (f :: * -> *) a.
Functor f =>
f (Cofree f a) -> Cofree f (f a)
distHisto (f (Cofree f a) -> Cofree f (f a))
-> (Cofree f a -> f (Cofree f a)) -> Cofree f a -> Cofree f (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree f a -> f (Cofree f a)
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
Cofree.unwrap) f (Cofree f a)
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 :: (forall b. f (h b) -> h (f b))
-> f (CofreeT f h a) -> CofreeT f h (f a)
distGHisto k :: forall b. f (h b) -> h (f b)
k = f (CofreeT f h a) -> CofreeT f h (f a)
d where d :: f (CofreeT f h a) -> CofreeT f h (f a)
d = h (CofreeF f (f a) (CofreeT f h (f a))) -> CofreeT f h (f a)
forall (f :: * -> *) (w :: * -> *) a.
w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a
CofreeT (h (CofreeF f (f a) (CofreeT f h (f a))) -> CofreeT f h (f a))
-> (f (CofreeT f h a) -> h (CofreeF f (f a) (CofreeT f h (f a))))
-> f (CofreeT f h a)
-> CofreeT f h (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (CofreeF f a (CofreeT f h a))
 -> CofreeF f (f a) (CofreeT f h (f a)))
-> h (f (CofreeF f a (CofreeT f h a)))
-> h (CofreeF f (f a) (CofreeT f h (f a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\fc :: f (CofreeF f a (CofreeT f h a))
fc -> (CofreeF f a (CofreeT f h a) -> a)
-> f (CofreeF f a (CofreeT f h a)) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CofreeF f a (CofreeT f h a) -> a
forall (f :: * -> *) a b. CofreeF f a b -> a
CCTC.headF f (CofreeF f a (CofreeT f h a))
fc f a -> f (CofreeT f h (f a)) -> CofreeF f (f a) (CofreeT f h (f a))
forall (f :: * -> *) a b. a -> f b -> CofreeF f a b
CCTC.:< (CofreeF f a (CofreeT f h a) -> CofreeT f h (f a))
-> f (CofreeF f a (CofreeT f h a)) -> f (CofreeT f h (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f (CofreeT f h a) -> CofreeT f h (f a)
d (f (CofreeT f h a) -> CofreeT f h (f a))
-> (CofreeF f a (CofreeT f h a) -> f (CofreeT f h a))
-> CofreeF f a (CofreeT f h a)
-> CofreeT f h (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CofreeF f a (CofreeT f h a) -> f (CofreeT f h a)
forall (f :: * -> *) a b. CofreeF f a b -> f b
CCTC.tailF) f (CofreeF f a (CofreeT f h a))
fc) (h (f (CofreeF f a (CofreeT f h a)))
 -> h (CofreeF f (f a) (CofreeT f h (f a))))
-> (f (CofreeT f h a) -> h (f (CofreeF f a (CofreeT f h a))))
-> f (CofreeT f h a)
-> h (CofreeF f (f a) (CofreeT f h (f a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (h (CofreeF f a (CofreeT f h a)))
-> h (f (CofreeF f a (CofreeT f h a)))
forall b. f (h b) -> h (f b)
k (f (h (CofreeF f a (CofreeT f h a)))
 -> h (f (CofreeF f a (CofreeT f h a))))
-> (f (CofreeT f h a) -> f (h (CofreeF f a (CofreeT f h a))))
-> f (CofreeT f h a)
-> h (f (CofreeF f a (CofreeT f h a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CofreeT f h a -> h (CofreeF f a (CofreeT f h a)))
-> f (CofreeT f h a) -> f (h (CofreeF f a (CofreeT f h a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CofreeT f h a -> h (CofreeF f a (CofreeT f h a))
forall (f :: * -> *) (w :: * -> *) a.
CofreeT f w a -> w (CofreeF f a (CofreeT f w a))
runCofreeT

chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b)
chrono :: (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono = (forall c. f (Cofree f c) -> Cofree f (f c))
-> (forall d. Free f (f d) -> f (Free f d))
-> (f (Cofree f b) -> b)
-> (a -> f (Free f a))
-> a
-> b
forall (w :: * -> *) (f :: * -> *) (m :: * -> *) b a.
(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 forall c. f (Cofree f c) -> Cofree f (f c)
forall (f :: * -> *) a.
Functor f =>
f (Cofree f a) -> Cofree f (f a)
distHisto forall d. Free f (f d) -> f (Free f d)
forall (f :: * -> *) a. Functor f => Free f (f a) -> f (Free f a)
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 :: (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 :: forall c. f (w c) -> w (f c)
w m :: forall c. m (f c) -> f (m c)
m = (forall c. f (CofreeT f w c) -> CofreeT f w (f c))
-> (forall d. FreeT f m (f d) -> f (FreeT f m d))
-> (f (CofreeT f w b) -> b)
-> (a -> f (FreeT f m a))
-> a
-> b
forall (w :: * -> *) (f :: * -> *) (m :: * -> *) b a.
(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 ((forall c. f (w c) -> w (f c))
-> f (CofreeT f w c) -> CofreeT f w (f c)
forall (f :: * -> *) (h :: * -> *) a.
(Functor f, Functor h) =>
(forall b. f (h b) -> h (f b))
-> f (CofreeT f h a) -> CofreeT f h (f a)
distGHisto forall c. f (w c) -> w (f c)
w) ((forall c. m (f c) -> f (m c))
-> FreeT f m (f d) -> f (FreeT f m d)
forall (f :: * -> *) (h :: * -> *) a.
(Functor f, Functor h) =>
(forall b. h (f b) -> f (h b))
-> FreeT f h (f a) -> f (FreeT f h a)
distGFutu forall c. m (f c) -> f (m c)
m)

-- | Mendler-style iteration
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata psi :: forall y. (y -> c) -> f y -> c
psi = (Fix f -> c) -> f (Fix f) -> c
forall y. (y -> c) -> f y -> c
psi ((forall y. (y -> c) -> f y -> c) -> Fix f -> c
forall c (f :: * -> *).
(forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata forall y. (y -> c) -> f y -> c
psi) (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unfix

-- | Mendler-style course-of-value iteration
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto psi :: forall y. (y -> c) -> (y -> f y) -> f y -> c
psi = (Fix f -> c) -> (Fix f -> f (Fix f)) -> f (Fix f) -> c
forall y. (y -> c) -> (y -> f y) -> f y -> c
psi ((forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
forall c (f :: * -> *).
(forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto forall y. (y -> c) -> (y -> f y) -> f y -> c
psi) Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unfix (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unfix

-- | Elgot algebras
elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot :: (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot phi :: f a -> a
phi psi :: b -> Either a (f b)
psi = b -> a
h where h :: b -> a
h = (a -> a
forall a. a -> a
id (a -> a) -> (f b -> a) -> Either a (f b) -> a
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| f a -> a
phi (f a -> a) -> (f b -> f a) -> f b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
h) (Either a (f b) -> a) -> (b -> Either a (f b)) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a (f b)
psi

-- | Elgot coalgebras: <http://comonad.com/reader/2008/elgot-coalgebras/>
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot :: ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot phi :: (a, f b) -> b
phi psi :: a -> f a
psi = a -> b
h where h :: a -> b
h = (a, f b) -> b
phi ((a, f b) -> b) -> (a -> (a, f b)) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a
forall a. a -> a
id (a -> a) -> (a -> f b) -> a -> (a, f b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
h (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
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 :: (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 :: Base t b -> b
f g :: forall c. Base t c -> Base t c
g t :: Base t (EnvT b (Cofree (Base t)) a) -> a
t = (forall b.
 Base t (EnvT b (Cofree (Base t)) b)
 -> EnvT b (Cofree (Base t)) (Base t b))
-> (forall c. Base t c -> Base t c)
-> (Base t (EnvT b (Cofree (Base t)) a) -> a)
-> t
-> a
forall t (w :: * -> *) a.
(Recursive t, Corecursive t, Comonad w) =>
(forall b. Base t (w b) -> w (Base t b))
-> (forall b. Base t b -> Base t b)
-> (Base t (w a) -> a)
-> t
-> a
gprepro ((Base t b -> b)
-> (forall c.
    Base t (Cofree (Base t) c) -> Cofree (Base t) (Base t c))
-> Base t (EnvT b (Cofree (Base t)) b)
-> EnvT b (Cofree (Base t)) (Base t b)
forall (f :: * -> *) (w :: * -> *) b a.
(Functor f, Comonad w) =>
(f b -> b)
-> (forall c. f (w c) -> w (f c))
-> f (EnvT b w a)
-> EnvT b w (f a)
distZygoT Base t b -> b
f forall c. Base t (Cofree (Base t) c) -> Cofree (Base t) (Base t c)
forall (f :: * -> *) a.
Functor f =>
f (Cofree f a) -> Cofree f (f a)
distHisto) forall c. Base t c -> Base t c
g Base t (EnvT b (Cofree (Base t)) a) -> a
t

-------------------------------------------------------------------------------
-- Effectful combinators
-------------------------------------------------------------------------------

-- | Effectful 'fold'.
--
-- This is a type specialisation of 'cata'.
--
-- An example terminating a recursion immediately:
--
-- >>> cataA (\alg -> case alg of { Nil -> pure (); Cons a _ -> Const [a] })  "hello"
-- Const "h"
--
cataA :: (Recursive t) => (Base t (f a) -> f a) -> t -> f a
cataA :: (Base t (f a) -> f a) -> t -> f a
cataA = (Base t (f a) -> f a) -> t -> f a
forall t a. Recursive t => (Base t a -> a) -> t -> a
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 :: (forall a. Base s (f a) -> f (Base t a)) -> s -> f t
transverse n :: forall a. Base s (f a) -> f (Base t a)
n = (Base s (f t) -> f t) -> s -> f t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata ((Base t t -> t) -> f (Base t t) -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (f (Base t t) -> f t)
-> (Base s (f t) -> f (Base t t)) -> Base s (f t) -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base s (f t) -> f (Base t t)
forall a. Base s (f a) -> f (Base t a)
n)

-- | A coeffectful version of 'hoist'.
--
-- Properties:
--
-- @
-- 'cotransverse' 'distAna' = 'runIdentity'
-- @
--
-- Examples:
--
-- Stateful transformations:
--
-- >>> :{
-- cotransverse
--   (\(u, b) -> case b of
--     Nil -> Nil
--     Cons x a -> Cons (if u then toUpper x else x) (not u, a))
--   (True, "foobar") :: String
-- :}
-- "FoObAr"
--
-- We can implement a variant of `zipWith`
--
-- >>> data Pair a = Pair a a deriving Functor
--
-- >>> :{
-- let zipWith' :: (a -> a -> b) -> [a] -> [a] -> [b]
--     zipWith' f xs ys = cotransverse g (Pair xs ys) where
--       g (Pair Nil        _)          = Nil
--       g (Pair _          Nil)        = Nil
--       g (Pair (Cons x a) (Cons y b)) = Cons (f x y) (Pair a b)
--     :}
--
-- >>> zipWith' (*) [1,2,3] [4,5,6]
-- [4,10,18]
--
-- >>> zipWith' (*) [1,2,3] [4,5,6,8]
-- [4,10,18]
--
-- >>> zipWith' (*) [1,2,3,3] [4,5,6]
-- [4,10,18]
--
cotransverse :: (Recursive s, Corecursive t, Functor f)
             => (forall a. f (Base s a) -> Base t (f a)) -> f s -> t
cotransverse :: (forall a. f (Base s a) -> Base t (f a)) -> f s -> t
cotransverse n :: forall a. f (Base s a) -> Base t (f a)
n = (f s -> Base t (f s)) -> f s -> t
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana (f (Base s s) -> Base t (f s)
forall a. f (Base s a) -> Base t (f a)
n (f (Base s s) -> Base t (f s))
-> (f s -> f (Base s s)) -> f s -> Base t (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> Base s s) -> f s -> f (Base s s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> Base s s
forall t. Recursive t => t -> Base t t
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 i c f a -> M1 i c' g a
gcoerce (M1 x :: f a
x) = g a -> M1 i c' g a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g a
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce f a
x)

-- R changes to/from P with GHC-7.4.2 at least.
instance GCoerce (K1 i c) (K1 j c) where
    gcoerce :: K1 i c a -> K1 j c a
gcoerce = c -> K1 j c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 j c a) -> (K1 i c a -> c) -> K1 i c a -> K1 j c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i c a -> c
forall i c k (p :: k). K1 i c p -> c
unK1

instance GCoerce U1 U1 where
    gcoerce :: U1 a -> U1 a
gcoerce = U1 a -> U1 a
forall a. a -> a
id

instance GCoerce V1 V1 where
    gcoerce :: V1 a -> V1 a
gcoerce = V1 a -> V1 a
forall a. a -> a
id

instance (GCoerce f g, GCoerce f' g') => GCoerce (f :*: f') (g :*: g') where
    gcoerce :: (:*:) f f' a -> (:*:) g g' a
gcoerce (x :: f a
x :*: y :: f' a
y) = f a -> g a
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce f a
x g a -> g' a -> (:*:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: f' a -> g' a
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce f' a
y

instance (GCoerce f g, GCoerce f' g') => GCoerce (f :+: f') (g :+: g') where
    gcoerce :: (:+:) f f' a -> (:+:) g g' a
gcoerce (L1 x :: f a
x) = g a -> (:+:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> g a
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce f a
x)
    gcoerce (R1 x :: f' a
x) = g' a -> (:+:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (f' a -> g' a
forall (f :: * -> *) (g :: * -> *) a. GCoerce f g => f a -> g a
gcoerce f' a
x)