{-# LANGUAGE Rank2Types #-}

-- | This module contains GHC-specific functions
module Control.Recursion.GHC ( transverse
                             , cotransverse
                             , hoist
                             ) where

import           Control.Recursion

-- | Should satisfy:
--
-- @
-- 'transverse' 'sequenceA' = 'pure'
-- @
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 forall a. Base s (f a) -> f (Base t a)
η = (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)
η)

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 forall a. f (Base s a) -> Base t (f a)
η = (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)
η (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)

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 forall a. Base s a -> Base t a
η = (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
η)
{-# NOINLINE [0] hoist #-}

hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu forall a. f a -> g a
η (Mu forall a. (f a -> a) -> a
f) = (forall a. (g a -> a) -> a) -> Mu g
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu ((f a -> a) -> a
forall a. (f a -> a) -> a
f ((f a -> a) -> a) -> ((g a -> a) -> f a -> a) -> (g a -> a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((g a -> a) -> (f a -> g a) -> f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a
forall a. f a -> g a
η))

hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu forall a. f a -> g a
ν (Nu a -> f a
f a
x) = (a -> g a) -> a -> Nu g
forall (f :: * -> *) a. (a -> f a) -> a -> Nu f
Nu (f a -> g a
forall a. f a -> g a
ν (f a -> g a) -> (a -> f a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
f) a
x

{-# RULES
  "hoist/hoistMu" forall (η :: forall a. f a -> f a) (f :: forall a. (f a -> a) -> a). hoist η (Mu f) = hoistMu η (Mu f);
     #-}

{-# RULES
  "hoist/hoistNu" forall (η :: forall a. f a -> f a) (f :: a -> f a) x. hoist η (Nu f x) = hoistNu η (Nu f x);
     #-}