{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuantifiedConstraints #-}

-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2023-2024 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
-}
module Data.Effect where

import Data.Coerce (Coercible, coerce)
import Data.Effect.HFunctor (HFunctor, hfmap)
import Data.Kind (Type)

-- | The kind for effects.
type Effect = (Type -> Type) -> Type -> Type

-- | An order of effect.
data EffectOrder = FirstOrder | HigherOrder
    deriving (Int -> EffectOrder -> ShowS
[EffectOrder] -> ShowS
EffectOrder -> String
(Int -> EffectOrder -> ShowS)
-> (EffectOrder -> String)
-> ([EffectOrder] -> ShowS)
-> Show EffectOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EffectOrder -> ShowS
showsPrec :: Int -> EffectOrder -> ShowS
$cshow :: EffectOrder -> String
show :: EffectOrder -> String
$cshowList :: [EffectOrder] -> ShowS
showList :: [EffectOrder] -> ShowS
Show, EffectOrder -> EffectOrder -> Bool
(EffectOrder -> EffectOrder -> Bool)
-> (EffectOrder -> EffectOrder -> Bool) -> Eq EffectOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EffectOrder -> EffectOrder -> Bool
== :: EffectOrder -> EffectOrder -> Bool
$c/= :: EffectOrder -> EffectOrder -> Bool
/= :: EffectOrder -> EffectOrder -> Bool
Eq, Eq EffectOrder
Eq EffectOrder =>
(EffectOrder -> EffectOrder -> Ordering)
-> (EffectOrder -> EffectOrder -> Bool)
-> (EffectOrder -> EffectOrder -> Bool)
-> (EffectOrder -> EffectOrder -> Bool)
-> (EffectOrder -> EffectOrder -> Bool)
-> (EffectOrder -> EffectOrder -> EffectOrder)
-> (EffectOrder -> EffectOrder -> EffectOrder)
-> Ord EffectOrder
EffectOrder -> EffectOrder -> Bool
EffectOrder -> EffectOrder -> Ordering
EffectOrder -> EffectOrder -> EffectOrder
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EffectOrder -> EffectOrder -> Ordering
compare :: EffectOrder -> EffectOrder -> Ordering
$c< :: EffectOrder -> EffectOrder -> Bool
< :: EffectOrder -> EffectOrder -> Bool
$c<= :: EffectOrder -> EffectOrder -> Bool
<= :: EffectOrder -> EffectOrder -> Bool
$c> :: EffectOrder -> EffectOrder -> Bool
> :: EffectOrder -> EffectOrder -> Bool
$c>= :: EffectOrder -> EffectOrder -> Bool
>= :: EffectOrder -> EffectOrder -> Bool
$cmax :: EffectOrder -> EffectOrder -> EffectOrder
max :: EffectOrder -> EffectOrder -> EffectOrder
$cmin :: EffectOrder -> EffectOrder -> EffectOrder
min :: EffectOrder -> EffectOrder -> EffectOrder
Ord)

type family OrderOf (e :: Effect) :: EffectOrder

type family OrderCase (o :: EffectOrder) a b where
    OrderCase 'FirstOrder a b = a
    OrderCase 'HigherOrder a b = b

data EffectForm = Polynomial | Exponential
    deriving (Int -> EffectForm -> ShowS
[EffectForm] -> ShowS
EffectForm -> String
(Int -> EffectForm -> ShowS)
-> (EffectForm -> String)
-> ([EffectForm] -> ShowS)
-> Show EffectForm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EffectForm -> ShowS
showsPrec :: Int -> EffectForm -> ShowS
$cshow :: EffectForm -> String
show :: EffectForm -> String
$cshowList :: [EffectForm] -> ShowS
showList :: [EffectForm] -> ShowS
Show, EffectForm -> EffectForm -> Bool
(EffectForm -> EffectForm -> Bool)
-> (EffectForm -> EffectForm -> Bool) -> Eq EffectForm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EffectForm -> EffectForm -> Bool
== :: EffectForm -> EffectForm -> Bool
$c/= :: EffectForm -> EffectForm -> Bool
/= :: EffectForm -> EffectForm -> Bool
Eq, Eq EffectForm
Eq EffectForm =>
(EffectForm -> EffectForm -> Ordering)
-> (EffectForm -> EffectForm -> Bool)
-> (EffectForm -> EffectForm -> Bool)
-> (EffectForm -> EffectForm -> Bool)
-> (EffectForm -> EffectForm -> Bool)
-> (EffectForm -> EffectForm -> EffectForm)
-> (EffectForm -> EffectForm -> EffectForm)
-> Ord EffectForm
EffectForm -> EffectForm -> Bool
EffectForm -> EffectForm -> Ordering
EffectForm -> EffectForm -> EffectForm
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EffectForm -> EffectForm -> Ordering
compare :: EffectForm -> EffectForm -> Ordering
$c< :: EffectForm -> EffectForm -> Bool
< :: EffectForm -> EffectForm -> Bool
$c<= :: EffectForm -> EffectForm -> Bool
<= :: EffectForm -> EffectForm -> Bool
$c> :: EffectForm -> EffectForm -> Bool
> :: EffectForm -> EffectForm -> Bool
$c>= :: EffectForm -> EffectForm -> Bool
>= :: EffectForm -> EffectForm -> Bool
$cmax :: EffectForm -> EffectForm -> EffectForm
max :: EffectForm -> EffectForm -> EffectForm
$cmin :: EffectForm -> EffectForm -> EffectForm
min :: EffectForm -> EffectForm -> EffectForm
Ord)

type family FormOf (e :: Effect) :: EffectForm

type family FormCase (f :: EffectForm) a b where
    FormCase 'Polynomial a b = a
    FormCase 'Exponential a b = b

type family LabelOf (e :: Effect)

class
    ( OrderOf e ~ 'FirstOrder
    , forall f g a. Coercible (e f a) (e g a)
    ) =>
    FirstOrder (e :: Effect)

{- | A higher-order polynomial functor.

Prevents resources from escaping the scope through unlift operations.
-}
class (FormOf e ~ 'Polynomial) => PolyHFunctor (e :: Effect)

{- | Enables algebraic handling even in the presence of higher-order effects.
In such cases, the scope of higher-order effects behaves according to a semantics similar to @mtl@,
where it may or may not become transactional depending on the order of the effect stack.

This follows the "weave" approach described in the "Effect Handlers in Scope" paper,
and is the method used in libraries such as @fused-effects@ and @polysemy@.

https://doi.org/10.1145/2633357.2633358
-}
class Weave (e :: Effect) where
    -- | The @weave@ method from the "Effect Handlers in Scope" paper.
    --
    --   https://doi.org/10.1145/2633357.2633358
    --
    --   To accommodate the effect representation used by @data-effects@ (which is generally not a @Functor@),
    --   the types have been transformed based on a Church encoding of @Coyoneda@.
    weave
        :: (Functor ctx)
        => ctx ()
        -> (forall x. ctx (m x) -> n (ctx x))
        -> (forall x. e n x -> (x -> ctx a) -> r)
        -> e m a
        -> r

-- * Nop Effect

-- | A effect with no operations.
data Nop :: Effect
    deriving anyclass (OrderOf Nop ~ 'FirstOrder
(OrderOf Nop ~ 'FirstOrder,
 forall (f :: * -> *) (g :: * -> *) a.
 Coercible (Nop f a) (Nop g a)) =>
FirstOrder Nop
forall (f :: * -> *) (g :: * -> *) a. Coercible (Nop f a) (Nop g a)
forall (e :: Effect).
(OrderOf e ~ 'FirstOrder,
 forall (f :: * -> *) (g :: * -> *) a. Coercible (e f a) (e g a)) =>
FirstOrder e
FirstOrder)

data NopLabel
type instance LabelOf Nop = NopLabel
type instance OrderOf Nop = 'FirstOrder
instance HFunctor Nop where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Nop f a -> Nop g a
hfmap forall x. f x -> g x
_ = \case {}
    {-# INLINE hfmap #-}
type instance FormOf Nop = 'Polynomial
instance PolyHFunctor Nop

-- * Embedding Effect

newtype Emb e (f :: Type -> Type) (a :: Type) = Emb {forall (e :: * -> *) (f :: * -> *) a. Emb e f a -> e a
getEmb :: e a}
    deriving anyclass (OrderOf (Emb e) ~ 'FirstOrder
(OrderOf (Emb e) ~ 'FirstOrder,
 forall (f :: * -> *) (g :: * -> *) a.
 Coercible (Emb e f a) (Emb e g a)) =>
FirstOrder (Emb e)
forall (e :: * -> *). OrderOf (Emb e) ~ 'FirstOrder
forall (f :: * -> *) (g :: * -> *) a.
Coercible (Emb e f a) (Emb e g a)
forall (e :: * -> *) (f :: * -> *) (g :: * -> *) a.
Coercible (Emb e f a) (Emb e g a)
forall (e :: Effect).
(OrderOf e ~ 'FirstOrder,
 forall (f :: * -> *) (g :: * -> *) a. Coercible (e f a) (e g a)) =>
FirstOrder e
FirstOrder)
    deriving newtype ((forall a b. (a -> b) -> Emb e f a -> Emb e f b)
-> (forall a b. a -> Emb e f b -> Emb e f a) -> Functor (Emb e f)
forall a b. a -> Emb e f b -> Emb e f a
forall a b. (a -> b) -> Emb e f a -> Emb e f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (e :: * -> *) (f :: * -> *) a b.
Functor e =>
a -> Emb e f b -> Emb e f a
forall (e :: * -> *) (f :: * -> *) a b.
Functor e =>
(a -> b) -> Emb e f a -> Emb e f b
$cfmap :: forall (e :: * -> *) (f :: * -> *) a b.
Functor e =>
(a -> b) -> Emb e f a -> Emb e f b
fmap :: forall a b. (a -> b) -> Emb e f a -> Emb e f b
$c<$ :: forall (e :: * -> *) (f :: * -> *) a b.
Functor e =>
a -> Emb e f b -> Emb e f a
<$ :: forall a b. a -> Emb e f b -> Emb e f a
Functor, Functor (Emb e f)
Functor (Emb e f) =>
(forall a. a -> Emb e f a)
-> (forall a b. Emb e f (a -> b) -> Emb e f a -> Emb e f b)
-> (forall a b c.
    (a -> b -> c) -> Emb e f a -> Emb e f b -> Emb e f c)
-> (forall a b. Emb e f a -> Emb e f b -> Emb e f b)
-> (forall a b. Emb e f a -> Emb e f b -> Emb e f a)
-> Applicative (Emb e f)
forall a. a -> Emb e f a
forall a b. Emb e f a -> Emb e f b -> Emb e f a
forall a b. Emb e f a -> Emb e f b -> Emb e f b
forall a b. Emb e f (a -> b) -> Emb e f a -> Emb e f b
forall a b c. (a -> b -> c) -> Emb e f a -> Emb e f b -> Emb e f c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (e :: * -> *) (f :: * -> *).
Applicative e =>
Functor (Emb e f)
forall (e :: * -> *) (f :: * -> *) a.
Applicative e =>
a -> Emb e f a
forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f a -> Emb e f b -> Emb e f a
forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f a -> Emb e f b -> Emb e f b
forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f (a -> b) -> Emb e f a -> Emb e f b
forall (e :: * -> *) (f :: * -> *) a b c.
Applicative e =>
(a -> b -> c) -> Emb e f a -> Emb e f b -> Emb e f c
$cpure :: forall (e :: * -> *) (f :: * -> *) a.
Applicative e =>
a -> Emb e f a
pure :: forall a. a -> Emb e f a
$c<*> :: forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f (a -> b) -> Emb e f a -> Emb e f b
<*> :: forall a b. Emb e f (a -> b) -> Emb e f a -> Emb e f b
$cliftA2 :: forall (e :: * -> *) (f :: * -> *) a b c.
Applicative e =>
(a -> b -> c) -> Emb e f a -> Emb e f b -> Emb e f c
liftA2 :: forall a b c. (a -> b -> c) -> Emb e f a -> Emb e f b -> Emb e f c
$c*> :: forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f a -> Emb e f b -> Emb e f b
*> :: forall a b. Emb e f a -> Emb e f b -> Emb e f b
$c<* :: forall (e :: * -> *) (f :: * -> *) a b.
Applicative e =>
Emb e f a -> Emb e f b -> Emb e f a
<* :: forall a b. Emb e f a -> Emb e f b -> Emb e f a
Applicative, Applicative (Emb e f)
Applicative (Emb e f) =>
(forall a b. Emb e f a -> (a -> Emb e f b) -> Emb e f b)
-> (forall a b. Emb e f a -> Emb e f b -> Emb e f b)
-> (forall a. a -> Emb e f a)
-> Monad (Emb e f)
forall a. a -> Emb e f a
forall a b. Emb e f a -> Emb e f b -> Emb e f b
forall a b. Emb e f a -> (a -> Emb e f b) -> Emb e f b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (e :: * -> *) (f :: * -> *).
Monad e =>
Applicative (Emb e f)
forall (e :: * -> *) (f :: * -> *) a. Monad e => a -> Emb e f a
forall (e :: * -> *) (f :: * -> *) a b.
Monad e =>
Emb e f a -> Emb e f b -> Emb e f b
forall (e :: * -> *) (f :: * -> *) a b.
Monad e =>
Emb e f a -> (a -> Emb e f b) -> Emb e f b
$c>>= :: forall (e :: * -> *) (f :: * -> *) a b.
Monad e =>
Emb e f a -> (a -> Emb e f b) -> Emb e f b
>>= :: forall a b. Emb e f a -> (a -> Emb e f b) -> Emb e f b
$c>> :: forall (e :: * -> *) (f :: * -> *) a b.
Monad e =>
Emb e f a -> Emb e f b -> Emb e f b
>> :: forall a b. Emb e f a -> Emb e f b -> Emb e f b
$creturn :: forall (e :: * -> *) (f :: * -> *) a. Monad e => a -> Emb e f a
return :: forall a. a -> Emb e f a
Monad, (forall m. Monoid m => Emb e f m -> m)
-> (forall m a. Monoid m => (a -> m) -> Emb e f a -> m)
-> (forall m a. Monoid m => (a -> m) -> Emb e f a -> m)
-> (forall a b. (a -> b -> b) -> b -> Emb e f a -> b)
-> (forall a b. (a -> b -> b) -> b -> Emb e f a -> b)
-> (forall b a. (b -> a -> b) -> b -> Emb e f a -> b)
-> (forall b a. (b -> a -> b) -> b -> Emb e f a -> b)
-> (forall a. (a -> a -> a) -> Emb e f a -> a)
-> (forall a. (a -> a -> a) -> Emb e f a -> a)
-> (forall a. Emb e f a -> [a])
-> (forall a. Emb e f a -> Bool)
-> (forall a. Emb e f a -> Int)
-> (forall a. Eq a => a -> Emb e f a -> Bool)
-> (forall a. Ord a => Emb e f a -> a)
-> (forall a. Ord a => Emb e f a -> a)
-> (forall a. Num a => Emb e f a -> a)
-> (forall a. Num a => Emb e f a -> a)
-> Foldable (Emb e f)
forall a. Eq a => a -> Emb e f a -> Bool
forall a. Num a => Emb e f a -> a
forall a. Ord a => Emb e f a -> a
forall m. Monoid m => Emb e f m -> m
forall a. Emb e f a -> Bool
forall a. Emb e f a -> Int
forall a. Emb e f a -> [a]
forall a. (a -> a -> a) -> Emb e f a -> a
forall m a. Monoid m => (a -> m) -> Emb e f a -> m
forall b a. (b -> a -> b) -> b -> Emb e f a -> b
forall a b. (a -> b -> b) -> b -> Emb e f a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Eq a) =>
a -> Emb e f a -> Bool
forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Num a) =>
Emb e f a -> a
forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Ord a) =>
Emb e f a -> a
forall (e :: * -> *) (f :: * -> *) m.
(Foldable e, Monoid m) =>
Emb e f m -> m
forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> Bool
forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> Int
forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> [a]
forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
(a -> a -> a) -> Emb e f a -> a
forall (e :: * -> *) (f :: * -> *) m a.
(Foldable e, Monoid m) =>
(a -> m) -> Emb e f a -> m
forall (e :: * -> *) (f :: * -> *) b a.
Foldable e =>
(b -> a -> b) -> b -> Emb e f a -> b
forall (e :: * -> *) (f :: * -> *) a b.
Foldable e =>
(a -> b -> b) -> b -> Emb e f a -> b
$cfold :: forall (e :: * -> *) (f :: * -> *) m.
(Foldable e, Monoid m) =>
Emb e f m -> m
fold :: forall m. Monoid m => Emb e f m -> m
$cfoldMap :: forall (e :: * -> *) (f :: * -> *) m a.
(Foldable e, Monoid m) =>
(a -> m) -> Emb e f a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Emb e f a -> m
$cfoldMap' :: forall (e :: * -> *) (f :: * -> *) m a.
(Foldable e, Monoid m) =>
(a -> m) -> Emb e f a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Emb e f a -> m
$cfoldr :: forall (e :: * -> *) (f :: * -> *) a b.
Foldable e =>
(a -> b -> b) -> b -> Emb e f a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Emb e f a -> b
$cfoldr' :: forall (e :: * -> *) (f :: * -> *) a b.
Foldable e =>
(a -> b -> b) -> b -> Emb e f a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Emb e f a -> b
$cfoldl :: forall (e :: * -> *) (f :: * -> *) b a.
Foldable e =>
(b -> a -> b) -> b -> Emb e f a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Emb e f a -> b
$cfoldl' :: forall (e :: * -> *) (f :: * -> *) b a.
Foldable e =>
(b -> a -> b) -> b -> Emb e f a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Emb e f a -> b
$cfoldr1 :: forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
(a -> a -> a) -> Emb e f a -> a
foldr1 :: forall a. (a -> a -> a) -> Emb e f a -> a
$cfoldl1 :: forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
(a -> a -> a) -> Emb e f a -> a
foldl1 :: forall a. (a -> a -> a) -> Emb e f a -> a
$ctoList :: forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> [a]
toList :: forall a. Emb e f a -> [a]
$cnull :: forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> Bool
null :: forall a. Emb e f a -> Bool
$clength :: forall (e :: * -> *) (f :: * -> *) a.
Foldable e =>
Emb e f a -> Int
length :: forall a. Emb e f a -> Int
$celem :: forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Eq a) =>
a -> Emb e f a -> Bool
elem :: forall a. Eq a => a -> Emb e f a -> Bool
$cmaximum :: forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Ord a) =>
Emb e f a -> a
maximum :: forall a. Ord a => Emb e f a -> a
$cminimum :: forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Ord a) =>
Emb e f a -> a
minimum :: forall a. Ord a => Emb e f a -> a
$csum :: forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Num a) =>
Emb e f a -> a
sum :: forall a. Num a => Emb e f a -> a
$cproduct :: forall (e :: * -> *) (f :: * -> *) a.
(Foldable e, Num a) =>
Emb e f a -> a
product :: forall a. Num a => Emb e f a -> a
Foldable)
    deriving stock (Functor (Emb e f)
Foldable (Emb e f)
(Functor (Emb e f), Foldable (Emb e f)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Emb e f a -> f (Emb e f b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Emb e f (f a) -> f (Emb e f a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Emb e f a -> m (Emb e f b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Emb e f (m a) -> m (Emb e f a))
-> Traversable (Emb e f)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Emb e f (m a) -> m (Emb e f a)
forall (f :: * -> *) a.
Applicative f =>
Emb e f (f a) -> f (Emb e f a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Emb e f a -> m (Emb e f b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Emb e f a -> f (Emb e f b)
forall (e :: * -> *) (f :: * -> *).
Traversable e =>
Functor (Emb e f)
forall (e :: * -> *) (f :: * -> *).
Traversable e =>
Foldable (Emb e f)
forall (e :: * -> *) (f :: * -> *) (m :: * -> *) a.
(Traversable e, Monad m) =>
Emb e f (m a) -> m (Emb e f a)
forall (e :: * -> *) (f :: * -> *) (f :: * -> *) a.
(Traversable e, Applicative f) =>
Emb e f (f a) -> f (Emb e f a)
forall (e :: * -> *) (f :: * -> *) (m :: * -> *) a b.
(Traversable e, Monad m) =>
(a -> m b) -> Emb e f a -> m (Emb e f b)
forall (e :: * -> *) (f :: * -> *) (f :: * -> *) a b.
(Traversable e, Applicative f) =>
(a -> f b) -> Emb e f a -> f (Emb e f b)
$ctraverse :: forall (e :: * -> *) (f :: * -> *) (f :: * -> *) a b.
(Traversable e, Applicative f) =>
(a -> f b) -> Emb e f a -> f (Emb e f b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Emb e f a -> f (Emb e f b)
$csequenceA :: forall (e :: * -> *) (f :: * -> *) (f :: * -> *) a.
(Traversable e, Applicative f) =>
Emb e f (f a) -> f (Emb e f a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Emb e f (f a) -> f (Emb e f a)
$cmapM :: forall (e :: * -> *) (f :: * -> *) (m :: * -> *) a b.
(Traversable e, Monad m) =>
(a -> m b) -> Emb e f a -> m (Emb e f b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Emb e f a -> m (Emb e f b)
$csequence :: forall (e :: * -> *) (f :: * -> *) (m :: * -> *) a.
(Traversable e, Monad m) =>
Emb e f (m a) -> m (Emb e f a)
sequence :: forall (m :: * -> *) a. Monad m => Emb e f (m a) -> m (Emb e f a)
Traversable)

data EmbLabel (e :: Type -> Type)
type instance LabelOf (Emb e) = EmbLabel e
type instance OrderOf (Emb e) = 'FirstOrder
instance HFunctor (Emb e) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Emb e f a -> Emb e g a
hfmap forall x. f x -> g x
_ = Emb e f a -> Emb e g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (Emb e) = 'Polynomial
instance PolyHFunctor (Emb e)

newtype Unemb e a = Unemb {forall {k} {k} (e :: k -> k -> *) (a :: k).
Unemb e a -> forall (f :: k). e f a
getUnemb :: forall f. e f a}

-- * Reader Effects

-- | An effect that holds a value of type @r@ in the context (environment).
data Ask r :: Effect where
    -- | Obtain a value from the environment.
    Ask :: Ask r f r

data AskLabel
type instance LabelOf (Ask r) = AskLabel
type instance OrderOf (Ask r) = 'FirstOrder
instance FirstOrder (Ask r)
instance HFunctor (Ask r) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ask r f a -> Ask r g a
hfmap forall x. f x -> g x
_ = Ask r f a -> Ask r g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (Ask r) = 'Polynomial
instance PolyHFunctor (Ask r)

-- | An effect that locally modifies the value held in the environment.
data Local r :: Effect where
    -- | Locally modifies the value held in the environment.
    Local
        :: (r -> r)
        -- ^ A function that transforms the original value to the modified value.
        -> f a
        -- ^ The local scope where the modification is applied.
        -> Local r f a

data LocalLabel
type instance LabelOf (Local r) = LocalLabel
type instance OrderOf (Local r) = 'HigherOrder
instance HFunctor (Local r) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Local r f a -> Local r g a
hfmap forall x. f x -> g x
phi (Local r -> r
f f a
a) = (r -> r) -> g a -> Local r g a
forall r (f :: * -> *) a. (r -> r) -> f a -> Local r f a
Local r -> r
f (f a -> g a
forall x. f x -> g x
phi f a
a)
    {-# INLINE hfmap #-}
type instance FormOf (Local r) = 'Polynomial
instance PolyHFunctor (Local r)

-- * State Effect

-- | An effect for holding mutable state values in the context.
data State s :: Effect where
    -- | Retrieves the current state value from the context.
    Get :: State s f s
    -- | Overwrites the state value in the context.
    Put :: s -> State s f ()

data StateLabel
type instance LabelOf (State s) = StateLabel
type instance OrderOf (State s) = 'FirstOrder
instance FirstOrder (State s)
instance HFunctor (State s) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> State s f a -> State s g a
hfmap forall x. f x -> g x
_ = State s f a -> State s g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (State s) = 'Polynomial
instance PolyHFunctor (State s)

-- * Writer Effects

-- | An effect that can accumulate values monoidally in a context.
data Tell w :: Effect where
    -- | Accumulates new values to the cumulative value held in the context.
    Tell :: w -> Tell w f ()

data TellLabel
type instance LabelOf (Tell w) = TellLabel
type instance OrderOf (Tell w) = 'FirstOrder
instance FirstOrder (Tell w)
instance HFunctor (Tell w) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Tell w f a -> Tell w g a
hfmap forall x. f x -> g x
_ = Tell w f a -> Tell w g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (Tell w) = 'Polynomial
instance PolyHFunctor (Tell w)

-- | An effect that performs local operations on accumulations in the context on a per-scope basis.
data WriterH w :: Effect where
    -- | Obtains the accumulated value in the scope and returns it together as a pair.
    Listen
        :: f a
        -- ^ The scope from which to obtain the accumulation.
        -> WriterH w f (w, a)
    -- | Modifies the accumulation in the scope based on the given function.
    Censor
        :: (w -> w)
        -- ^ A function for modifying the accumulated value.
        -> f a
        -- ^ The scope where the modification is applied.
        -> WriterH w f a

data WriterHLabel
type instance LabelOf (WriterH w) = WriterHLabel
type instance OrderOf (WriterH w) = 'HigherOrder
instance HFunctor (WriterH w) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> WriterH w f a -> WriterH w g a
hfmap forall x. f x -> g x
phi = \case
        Listen f a
a -> g a -> WriterH w g (w, a)
forall (f :: * -> *) a w. f a -> WriterH w f (w, a)
Listen (g a -> WriterH w g (w, a)) -> g a -> WriterH w g (w, a)
forall a b. (a -> b) -> a -> b
$ f a -> g a
forall x. f x -> g x
phi f a
a
        Censor w -> w
f f a
a -> (w -> w) -> g a -> WriterH w g a
forall w (f :: * -> *) a. (w -> w) -> f a -> WriterH w f a
Censor w -> w
f (f a -> g a
forall x. f x -> g x
phi f a
a)
    {-# INLINE hfmap #-}
type instance FormOf (WriterH w) = 'Polynomial
instance PolyHFunctor (WriterH w)

-- * Exception Effects

-- | An effect to escape from the normal control structure with an exception value of type @e@ in the middle of a context.
data Throw e :: Effect where
    -- | Throws an exception; that is, escapes from the normal control structure with an exception value in the middle of a context.
    Throw :: e -> Throw e f a

data ThrowLabel
type instance LabelOf (Throw e) = ThrowLabel
type instance OrderOf (Throw e) = 'FirstOrder
instance FirstOrder (Throw e)
instance HFunctor (Throw e) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Throw e f a -> Throw e g a
hfmap forall x. f x -> g x
_ = Throw e f a -> Throw e g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (Throw e) = 'Polynomial
instance PolyHFunctor (Throw e)

-- | An effect to catch exceptions.
data Catch e :: Effect where
    -- | Catches exceptions within a scope and processes them according to the given exception handler.
    Catch
        :: f a
        -- ^ The scope in which to catch exceptions.
        -> (e -> f a)
        -- ^ Exception handler. Defines the processing to perform when an exception is thrown within the scope.
        -> Catch e f a

data CatchLabel
type instance LabelOf (Catch e) = CatchLabel
type instance OrderOf (Catch e) = 'HigherOrder
instance HFunctor (Catch e) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Catch e f a -> Catch e g a
hfmap forall x. f x -> g x
phi (Catch f a
a e -> f a
hdl) = g a -> (e -> g a) -> Catch e g a
forall (f :: * -> *) a e. f a -> (e -> f a) -> Catch e f a
Catch (f a -> g a
forall x. f x -> g x
phi f a
a) (f a -> g a
forall x. f x -> g x
phi (f a -> g a) -> (e -> f a) -> e -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> f a
hdl)
    {-# INLINE hfmap #-}
type instance FormOf (Catch e) = 'Polynomial
instance PolyHFunctor (Catch e)

-- * Non-Determinism Effects

-- | An effect that eliminates a branch by causing the current branch context of a non-deterministic computation to fail.
data Empty :: Effect where
    -- | Eliminates a branch by causing the current branch context of a non-deterministic computation to fail.
    Empty :: Empty f a

data EmptyLabel
type instance LabelOf Empty = EmptyLabel
type instance OrderOf Empty = 'FirstOrder
instance FirstOrder Empty
instance HFunctor Empty where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Empty f a -> Empty g a
hfmap forall x. f x -> g x
_ = Empty f a -> Empty g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf Empty = 'Polynomial
instance PolyHFunctor Empty

-- | An effect that splits the computation into two branches.
data Choose :: Effect where
    -- | Splits the computation into two branches.
    -- As a result of executing @choose@, the world branches into one where `False` is returned and one where `True` is returned.
    Choose :: Choose f Bool

data ChooseLabel
type instance LabelOf Choose = ChooseLabel
type instance OrderOf Choose = 'FirstOrder
instance FirstOrder Choose
instance HFunctor Choose where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Choose f a -> Choose g a
hfmap forall x. f x -> g x
_ = Choose f a -> Choose g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf Choose = 'Polynomial
instance PolyHFunctor Choose

{- |
An effect that executes two branches as scopes.
A higher-order version of the t`Choose` effect.
-}
data ChooseH :: Effect where
    -- | Executes the given two scopes as branches.
    -- Even if one fails due to the `empty` operation, the whole does not fail as long as the other does not fail.
    ChooseH :: f a -> f a -> ChooseH f a

data ChooseHLabel
type instance LabelOf ChooseH = ChooseHLabel
type instance OrderOf ChooseH = 'HigherOrder
instance HFunctor ChooseH where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ChooseH f a -> ChooseH g a
hfmap forall x. f x -> g x
phi (ChooseH f a
a f a
b) = g a -> g a -> ChooseH g a
forall (f :: * -> *) a. f a -> f a -> ChooseH f a
ChooseH (f a -> g a
forall x. f x -> g x
phi f a
a) (f a -> g a
forall x. f x -> g x
phi f a
b)
    {-# INLINE hfmap #-}
type instance FormOf ChooseH = 'Polynomial
instance PolyHFunctor ChooseH

-- * Fail Effect

data Fail :: Effect where
    Fail :: String -> Fail f a

data FailLabel
type instance LabelOf Fail = FailLabel
type instance OrderOf Fail = 'FirstOrder
instance FirstOrder Fail
instance HFunctor Fail where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Fail f a -> Fail g a
hfmap forall x. f x -> g x
_ = Fail f a -> Fail g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf Fail = 'Polynomial
instance PolyHFunctor Fail

-- * Fix Effect

data Fix :: Effect where
    Efix :: (a -> f a) -> Fix f a

data FixLabel
type instance LabelOf Fix = FixLabel
type instance OrderOf Fix = 'HigherOrder
instance HFunctor Fix where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Fix f a -> Fix g a
hfmap forall x. f x -> g x
phi (Efix a -> f a
f) = (a -> g a) -> Fix g a
forall a (f :: * -> *). (a -> f a) -> Fix f a
Efix ((a -> g a) -> Fix g a) -> (a -> g a) -> Fix g a
forall a b. (a -> b) -> a -> b
$ f a -> g a
forall x. f x -> g x
phi (f a -> g a) -> (a -> f a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
f
    {-# INLINE hfmap #-}
type instance FormOf Fix = 'Polynomial
instance PolyHFunctor Fix

-- * Unlift Effect

data UnliftBase b f (a :: Type) where
    WithRunInBase :: ((forall x. f x -> b x) -> b a) -> UnliftBase b f a

type UnliftIO = UnliftBase IO

data UnliftBaseLabel (b :: Type -> Type)
type instance LabelOf (UnliftBase b) = UnliftBaseLabel b
type instance OrderOf (UnliftBase b) = 'HigherOrder
instance HFunctor (UnliftBase b) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> UnliftBase b f a -> UnliftBase b g a
hfmap forall x. f x -> g x
phi (WithRunInBase (forall x. f x -> b x) -> b a
f) = ((forall x. g x -> b x) -> b a) -> UnliftBase b g a
forall (f :: * -> *) (b :: * -> *) a.
((forall x. f x -> b x) -> b a) -> UnliftBase b f a
WithRunInBase \forall x. g x -> b x
run -> (forall x. f x -> b x) -> b a
f ((forall x. f x -> b x) -> b a) -> (forall x. f x -> b x) -> b a
forall a b. (a -> b) -> a -> b
$ g x -> b x
forall x. g x -> b x
run (g x -> b x) -> (f x -> g x) -> f x -> b x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
forall x. f x -> g x
phi
    {-# INLINE hfmap #-}
type instance FormOf (UnliftBase b) = 'Exponential

-- * CallCC Effect (Sub/Jump-based)

data CC ref :: Effect where
    SubFork :: CC ref f (Either (ref a) a)
    Jump :: ref a -> a -> CC ref f b

data CCLabel
type instance LabelOf (CC ref) = CCLabel
type instance OrderOf (CC ref) = 'FirstOrder
instance FirstOrder (CC ref)
instance HFunctor (CC ref) where
    hfmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> CC ref f a -> CC ref g a
hfmap forall x. f x -> g x
_ = CC ref f a -> CC ref g a
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE hfmap #-}
type instance FormOf (CC ref) = 'Polynomial
instance PolyHFunctor (CC ref)