{-# 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(..)
  -- * 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.Functor.Compose (Compose(..))
import Data.List.NonEmpty(NonEmpty((:|)), nonEmpty, toList)
import Data.Tree (Tree (..))
#ifdef __GLASGOW_HASKELL__
#if HAS_GENERIC
import GHC.Generics (Generic (..), M1 (..), V1, U1, K1 (..), (:+:) (..), (:*:) (..))
#endif
#endif
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.Monad (void)
-- >>> import Data.Char (toUpper)
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.List (partition)
-- >>> import Data.Maybe (maybeToList)
--
-- >>> let showTree = putStrLn . go where go (Node x xs) = if null xs then x else "(" ++ unwords (x : map go xs) ++ ")"

-- | 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]@.
-- Ifthat 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
#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

  -- | A generalization of 'foldr'. The elements of the base functor, called the
  -- "recursive positions", give the result of folding the sub-tree at that
  -- position.
  --
  -- >>> :{
  -- >>> let oursum = cata $ \case
  -- >>>        Nil        -> 0
  -- >>>        Cons x acc -> x + acc
  -- >>> :}
  --
  -- >>> oursum [1,2,3]
  -- 6
  --
  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

  -- | A variant of 'cata' in which recursive positions also include the
  -- original sub-tree, in addition to the result of folding that sub-tree.
  --
  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

-- | 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
#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

  -- | 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]
  --
  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

-- | An optimized version of @cata f . ana 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 = hylo 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]
--
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

-- | An alias for 'cata'.
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

-- | An alias for 'ana'.
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

-- | An alias for 'hylo'.
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

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 (Tree a) = TreeF a
instance Recursive (Tree a) where
  project :: Tree a -> Base (Tree a) (Tree a)
project (Node x :: a
x xs :: Forest a
xs) = a -> Forest a -> TreeF a (Tree a)
forall a b. a -> ForestF a b -> TreeF a b
NodeF a
x Forest a
xs
instance Corecursive (Tree a) where
  embed :: Base (Tree a) (Tree a) -> Tree a
embed (NodeF x xs) = a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Node a
x Forest a
xs

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 (Free f a) a
a -> Base (F 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 (Free f a) b -> Base (Free f a) b
forall b. Base (F f a) b -> Base (F f a) b
nat a -> Base (Free f a) a
a -> Base (F 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 (Free f a) b) -> Base (Free f a) (m b)
forall b. m (Base (F f a) b) -> Base (F f a) (m b)
dist forall b. Base (Free f a) b -> Base (Free f a) b
forall b. Base (F f a) b -> Base (F f a) b
nat a -> Base (Free f a) (m a)
a -> Base (F 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 = f (w b) -> b
f (f (w b) -> b) -> (a -> f (w b)) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> w b) -> f (m a) -> f (w b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (w b) -> w b) -> (m a -> f (m a)) -> m a -> w b
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo f (w b) -> w b
alg m a -> f (m a)
coalg) (f (m a) -> f (w b)) -> (a -> f (m a)) -> a -> f (w b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f (m a)
g where
  coalg :: m a -> f (m a)
coalg = (m (m a) -> m a) -> f (m (m a)) -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (f (m (m a)) -> f (m a)) -> (m a -> f (m (m a))) -> m a -> f (m a)
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
  alg :: f (w b) -> w b
alg   = (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) -> (f (w b) -> w (f (w b))) -> f (w b) -> 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)))
-> (f (w b) -> f (w (w b))) -> f (w b) -> w (f (w b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w b -> w (w b)) -> f (w b) -> 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
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
-------------------------------------------------------------------------------

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

-- | 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 :: (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)

-- | 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 :: 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

-------------------------------------------------------------------------------
-- 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)

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))

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 (f :: * -> *) a. (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 (f :: * -> *) a. (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

-- | 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

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' :: 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 :: (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)