{-# 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 = to . gcoerce . 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 = c where c = f . fmap c . project
-- | A variant of 'cata' in which recursive positions also include the
-- original sub-tree, in addition to the result of folding that sub-tree.
--
para :: (Base t (t, a) -> a) -> t -> a
para t = p where p x = t . fmap ((,) <*> p) $ project x
gpara :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (EnvT t w a) -> a) -> t -> a
gpara t = gzygo embed t
-- | Fokkinga's prepromorphism
prepro
:: Corecursive t
=> (forall b. Base t b -> Base t b)
-> (Base t a -> a)
-> t
-> a
prepro e f = c where c = f . fmap (c . hoist e) . project
--- | A generalized prepromorphism
gprepro
:: (Corecursive t, Comonad w)
=> (forall b. Base t (w b) -> w (Base t b))
-> (forall c. Base t c -> Base t c)
-> (Base t (w a) -> a)
-> t
-> a
gprepro k e f = extract . c where c = fmap f . k . fmap (duplicate . c . hoist e) . project
distPara :: Corecursive t => Base t (t, a) -> (t, Base t a)
distPara = distZygo embed
distParaT :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> Base t (EnvT t w a) -> EnvT t w (Base t a)
distParaT t = distZygoT embed t
-- | A recursive datatype which can be rolled up one recursion layer at a time.
--
-- For example, a value of type @'ListF' a [a]@ can be rolled up into a @[a]@.
-- This @[a]@ can then be used in a 'Cons' to construct another @'ListF' a [a]@,
-- which can be rolled up as well, and so on.
--
-- Typically, 'Corecursive' types also have a 'Recursive' instance, in which
-- case 'embed' and 'project' are inverses.
class Functor (Base t) => Corecursive t where
-- | Roll up a single recursion layer.
--
-- >>> embed (Cons 1 [2,3])
-- [1,2,3]
embed :: Base t t -> t
#ifdef HAS_GENERIC
default embed :: (Generic t, Generic (Base t t), GCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t
embed = to . gcoerce . 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 where a = embed . fmap a . g
apo :: (a -> Base t (Either t a)) -> a -> t
apo g = a where a = embed . (fmap (either id a)) . g
-- | Fokkinga's postpromorphism
postpro
:: Recursive t
=> (forall b. Base t b -> Base t b) -- natural transformation
-> (a -> Base t a) -- a (Base t)-coalgebra
-> a -- seed
-> t
postpro e g = a where a = embed . fmap (hoist e . a) . g
-- | A generalized postpromorphism
gpostpro
:: (Recursive t, Monad m)
=> (forall b. m (Base t b) -> Base t (m b)) -- distributive law
-> (forall c. Base t c -> Base t c) -- natural transformation
-> (a -> Base t (m a)) -- a (Base t)-m-coalgebra
-> a -- seed
-> t
gpostpro k e g = a . return where a = embed . fmap (hoist e . a . join) . k . liftM g
-- | An 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 g = h where h = f . fmap h . g
-- | An alias for 'cata'.
fold :: Recursive t => (Base t a -> a) -> t -> a
fold = cata
-- | An alias for 'ana'.
unfold :: Corecursive t => (a -> Base t a) -> a -> t
unfold = ana
-- | An alias for 'hylo'.
refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refold = hylo
type instance Base [a] = ListF a
instance Recursive [a] where
project (x:xs) = Cons x xs
project [] = Nil
para f (x:xs) = f (Cons x (xs, para f xs))
para f [] = f Nil
instance Corecursive [a] where
embed (Cons x xs) = x:xs
embed Nil = []
apo f a = case f a of
Cons x (Left xs) -> x : xs
Cons x (Right b) -> x : apo f b
Nil -> []
type instance Base (NonEmpty a) = NonEmptyF a
instance Recursive (NonEmpty a) where
project (x:|xs) = NonEmptyF x $ nonEmpty xs
instance Corecursive (NonEmpty a) where
embed = (:|) <$> NEF.head <*> (maybe [] toList <$> NEF.tail)
type instance Base (Tree a) = TreeF a
instance Recursive (Tree a) where
project (Node x xs) = NodeF x xs
instance Corecursive (Tree a) where
embed (NodeF x xs) = Node x xs
type instance Base Natural = Maybe
instance Recursive Natural where
project 0 = Nothing
project n = Just (n - 1)
instance Corecursive Natural where
embed = maybe 0 (+1)
-- | Cofree comonads are Recursive/Corecursive
type instance Base (Cofree f a) = CofreeF f a
instance Functor f => Recursive (Cofree f a) where
project (x :< xs) = x CCTC.:< xs
instance Functor f => Corecursive (Cofree f a) where
embed (x CCTC.:< xs) = x :< xs
-- | Cofree tranformations of comonads are Recursive/Corecusive
type instance Base (CofreeT f w a) = Compose w (CofreeF f a)
instance (Functor w, Functor f) => Recursive (CofreeT f w a) where
project = Compose . runCofreeT
instance (Functor w, Functor f) => Corecursive (CofreeT f w a) where
embed = CofreeT . getCompose
-- | Free monads are Recursive/Corecursive
type instance Base (Free f a) = FreeF f a
instance Functor f => Recursive (Free f a) where
project (Pure a) = CMTF.Pure a
project (Free f) = CMTF.Free f
improveF :: Functor f => CMFC.F f a -> Free f a
improveF x = CMFC.improve (CMFC.fromF x)
-- | It may be better to work with the instance for `CMFC.F` directly.
instance Functor f => Corecursive (Free f a) where
embed (CMTF.Pure a) = Pure a
embed (CMTF.Free f) = Free f
ana coalg = improveF . ana coalg
postpro nat coalg = improveF . postpro nat coalg
gpostpro dist nat coalg = improveF . gpostpro dist nat coalg
-- | Free transformations of monads are Recursive/Corecursive
type instance Base (FreeT f m a) = Compose m (FreeF f a)
instance (Functor m, Functor f) => Recursive (FreeT f m a) where
project = Compose . runFreeT
instance (Functor m, Functor f) => Corecursive (FreeT f m a) where
embed = FreeT . getCompose
-- If you are looking for instances for the free MonadPlus, please use the
-- instance for FreeT f [].
-- If you are looking for instances for the free alternative and free
-- applicative, I'm sorry to disapoint you but you won't find them in this
-- package. They can be considered recurive, but using non-uniform recursion;
-- this package only implements uniformly recursive folds / unfolds.
-- | Example boring stub for non-recursive data types
type instance Base (Maybe a) = Const (Maybe a)
instance Recursive (Maybe a) where project = Const
instance Corecursive (Maybe a) where embed = getConst
-- | Example boring stub for non-recursive data types
type instance Base (Either a b) = Const (Either a b)
instance Recursive (Either a b) where project = Const
instance Corecursive (Either a b) where embed = getConst
-- | A generalized catamorphism
gfold, gcata
:: (Recursive t, Comonad w)
=> (forall b. Base t (w b) -> w (Base t b)) -- ^ a distributive law
-> (Base t (w a) -> a) -- ^ a (Base t)-w-algebra
-> t -- ^ fixed point
-> a
gcata k g = g . extract . c where
c = k . fmap (duplicate . fmap g . c) . project
gfold k g t = gcata k g t
distCata :: Functor f => f (Identity a) -> Identity (f a)
distCata = Identity . fmap runIdentity
-- | A generalized anamorphism
gunfold, gana
:: (Corecursive t, Monad m)
=> (forall b. m (Base t b) -> Base t (m b)) -- ^ a distributive law
-> (a -> Base t (m a)) -- ^ a (Base t)-m-coalgebra
-> a -- ^ seed
-> t
gana k f = a . return . f where
a = embed . fmap (a . liftM f . join) . k
gunfold k f t = gana k f t
distAna :: Functor f => Identity (f a) -> f (Identity a)
distAna = fmap Identity . runIdentity
-- | A generalized hylomorphism
grefold, ghylo
:: (Comonad w, Functor f, Monad m)
=> (forall c. f (w c) -> w (f c))
-> (forall d. m (f d) -> f (m d))
-> (f (w b) -> b)
-> (a -> f (m a))
-> a
-> b
ghylo w m f g = f . fmap (hylo alg coalg) . g where
coalg = fmap join . m . liftM g
alg = fmap f . w . fmap duplicate
grefold w m f g a = ghylo w m f g a
futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t
futu = gana distFutu
gfutu :: (Corecursive t, Functor m, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -> (a -> Base t (FreeT (Base t) m a)) -> a -> t
gfutu g = gana (distGFutu g)
distFutu :: Functor f => Free f (f a) -> f (Free f a)
distFutu (Pure fx) = Pure <$> fx
distFutu (Free ff) = Free . distFutu <$> ff
distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> FreeT f h (f a) -> f (FreeT f h a)
distGFutu k = d where
d = fmap FreeT . k . fmap d' . runFreeT
d' (CMTF.Pure ff) = CMTF.Pure <$> ff
d' (CMTF.Free ff) = CMTF.Free . d <$> ff
-------------------------------------------------------------------------------
-- Fix
-------------------------------------------------------------------------------
type instance Base (Fix f) = f
instance Functor f => Recursive (Fix f) where
project (Fix a) = a
instance Functor f => Corecursive (Fix f) where
embed = Fix
-- | Convert from one recursive type to another.
--
-- >>> showTree $ hoist (\(NonEmptyF h t) -> NodeF [h] (maybeToList t)) ( 'a' :| "bcd")
-- (a (b (c d)))
--
hoist :: (Recursive s, Corecursive t)
=> (forall a. Base s a -> Base t a) -> s -> t
hoist n = cata (embed . n)
-- | Convert from one recursive representation to another.
--
-- >>> refix ["foo", "bar"] :: Fix (ListF String)
-- Fix (Cons "foo" (Fix (Cons "bar" (Fix Nil))))
--
refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix = cata embed
-------------------------------------------------------------------------------
-- Lambek
-------------------------------------------------------------------------------
-- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed'
lambek :: (Recursive t, Corecursive t) => (t -> Base t t)
lambek = cata (fmap embed)
-- | The dual of Lambek's lemma, provides a default definition for 'embed' in terms of 'ana' and 'project'
colambek :: (Recursive t, Corecursive t) => (Base t t -> t)
colambek = ana (fmap project)
type instance Base (Mu f) = f
instance Functor f => Recursive (Mu f) where
project = lambek
cata f (Mu g) = g f
instance Functor f => Corecursive (Mu f) where
embed m = Mu (\f -> f (fmap (fold f) m))
type instance Base (Nu f) = f
instance Functor f => Corecursive (Nu f) where
embed = colambek
ana = Nu
instance Functor f => Recursive (Nu f) where
project (Nu f a) = Nu f <$> f a
-- | Church encoded free monads are Recursive/Corecursive, in the same way that
-- 'Mu' is.
type instance Base (CMFC.F f a) = FreeF f a
cmfcCata :: (a -> r) -> (f r -> r) -> CMFC.F f a -> r
cmfcCata p f (CMFC.F run) = run p f
instance Functor f => Recursive (CMFC.F f a) where
project = lambek
cata f = cmfcCata (f . CMTF.Pure) (f . CMTF.Free)
instance Functor f => Corecursive (CMFC.F f a) where
embed (CMTF.Pure a) = CMFC.F $ \p _ -> p a
embed (CMTF.Free fr) = CMFC.F $ \p f -> f $ fmap (cmfcCata p f) fr
zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo f = gfold (distZygo f)
distZygo
:: Functor f
=> (f b -> b) -- An f-algebra
-> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion
distZygo g m = (g (fmap fst m), fmap snd m)
gzygo
:: (Recursive t, Comonad w)
=> (Base t b -> b)
-> (forall c. Base t (w c) -> w (Base t c))
-> (Base t (EnvT b w a) -> a)
-> t
-> a
gzygo f w = gfold (distZygoT f w)
distZygoT
:: (Functor f, Comonad w)
=> (f b -> b) -- An f-w-algebra to use for semi-mutual recursion
-> (forall c. f (w c) -> w (f c)) -- A base Distributive law
-> f (EnvT b w a) -> EnvT b w (f a) -- A new distributive law that adds semi-mutual recursion
distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe))
where getEnv (EnvT e _) = e
gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t
gapo g = gunfold (distGApo g)
distApo :: Recursive t => Either t (Base t a) -> Base t (Either t a)
distApo = distGApo project
distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a)
distGApo f = either (fmap Left . f) (fmap Right)
distGApoT
:: (Functor f, Functor m)
=> (b -> f b)
-> (forall c. m (f c) -> f (m c))
-> ExceptT b m (f a)
-> f (ExceptT b m a)
distGApoT g k = fmap ExceptT . k . fmap (distGApo g) . runExceptT
-- | Course-of-value iteration
histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a
histo = gcata distHisto
ghisto :: (Recursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (CofreeT (Base t) w a) -> a) -> t -> a
ghisto g = gcata (distGHisto g)
distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a)
distHisto fc = fmap extract fc :< fmap (distHisto . Cofree.unwrap) fc
distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (CofreeT f h a) -> CofreeT f h (f a)
distGHisto k = d where d = CofreeT . fmap (\fc -> fmap CCTC.headF fc CCTC.:< fmap (d . CCTC.tailF) fc) . k . fmap runCofreeT
chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b)
chrono = ghylo distHisto distFutu
gchrono :: (Functor f, Functor w, Functor m, Comonad w, Monad m) =>
(forall c. f (w c) -> w (f c)) ->
(forall c. m (f c) -> f (m c)) ->
(f (CofreeT f w b) -> b) -> (a -> f (FreeT f m a)) ->
(a -> b)
gchrono w m = ghylo (distGHisto w) (distGFutu m)
-- | Mendler-style iteration
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata psi = psi (mcata psi) . unFix
-- | Mendler-style course-of-value iteration
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto psi = psi (mhisto psi) unFix . unFix
-- | Elgot algebras
elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot phi psi = h where h = (id ||| phi . fmap h) . psi
-- | Elgot coalgebras: <http://comonad.com/reader/2008/elgot-coalgebras/>
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot phi psi = h where h = phi . (id &&& fmap h . psi)
-- | Zygohistomorphic prepromorphisms:
--
-- A corrected and modernized version of <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>
zygoHistoPrepro
:: (Corecursive t, Recursive t)
=> (Base t b -> b)
-> (forall c. Base t c -> Base t c)
-> (Base t (EnvT b (Cofree (Base t)) a) -> a)
-> t
-> a
zygoHistoPrepro f g t = gprepro (distZygoT f distHisto) g t
-------------------------------------------------------------------------------
-- Effectful combinators
-------------------------------------------------------------------------------
-- | 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 = cata
-- | An effectful version of 'hoist'.
--
-- Properties:
--
-- @
-- 'transverse' 'sequenceA' = 'pure'
-- @
--
-- Examples:
--
-- The weird type of first argument allows user to decide
-- an order of sequencing:
--
-- >>> transverse (\x -> print (void x) *> sequence x) "foo" :: IO String
-- Cons 'f' ()
-- Cons 'o' ()
-- Cons 'o' ()
-- Nil
-- "foo"
--
-- >>> transverse (\x -> sequence x <* print (void x)) "foo" :: IO String
-- Nil
-- Cons 'o' ()
-- Cons 'o' ()
-- Cons 'f' ()
-- "foo"
--
transverse :: (Recursive s, Corecursive t, Functor f)
=> (forall a. Base s (f a) -> f (Base t a)) -> s -> f t
transverse n = cata (fmap embed . n)
-- | A coeffectful version of 'hoist'.
--
-- Properties:
--
-- @
-- 'cotransverse' 'distAna' = 'runIdentity'
-- @
--
-- Examples:
--
-- Stateful transformations:
--
-- >>> :{
-- cotransverse
-- (\(u, b) -> case b of
-- Nil -> Nil
-- Cons x a -> Cons (if u then toUpper x else x) (not u, a))
-- (True, "foobar") :: String
-- :}
-- "FoObAr"
--
-- We can implement a variant of `zipWith`
--
-- >>> data Pair a = Pair a a deriving Functor
--
-- >>> :{
-- let zipWith' :: forall a b. (a -> a -> b) -> [a] -> [a] -> [b]
-- zipWith' f xs ys = cotransverse g (Pair xs ys) where
-- g :: Pair (ListF a c) -> ListF b (Pair c)
-- g (Pair Nil _) = Nil
-- g (Pair _ Nil) = Nil
-- g (Pair (Cons x a) (Cons y b)) = Cons (f x y) (Pair a b)
-- :}
--
-- >>> zipWith' (*) [1,2,3] [4,5,6]
-- [4,10,18]
--
-- >>> zipWith' (*) [1,2,3] [4,5,6,8]
-- [4,10,18]
--
-- >>> zipWith' (*) [1,2,3,3] [4,5,6]
-- [4,10,18]
--
cotransverse :: (Recursive s, Corecursive t, Functor f)
=> (forall a. f (Base s a) -> Base t (f a)) -> f s -> t
cotransverse n = ana (n . fmap project)
-------------------------------------------------------------------------------
-- GCoerce
-------------------------------------------------------------------------------
class GCoerce f g where
gcoerce :: f a -> g a
instance GCoerce f g => GCoerce (M1 i c f) (M1 i c' g) where
gcoerce (M1 x) = M1 (gcoerce x)
-- R changes to/from P with GHC-7.4.2 at least.
instance GCoerce (K1 i c) (K1 j c) where
gcoerce = K1 . unK1
instance GCoerce U1 U1 where
gcoerce = id
instance GCoerce V1 V1 where
gcoerce = id
instance (GCoerce f g, GCoerce f' g') => GCoerce (f :*: f') (g :*: g') where
gcoerce (x :*: y) = gcoerce x :*: gcoerce y
instance (GCoerce f g, GCoerce f' g') => GCoerce (f :+: f') (g :+: g') where
gcoerce (L1 x) = L1 (gcoerce x)
gcoerce (R1 x) = R1 (gcoerce x)