{-# 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.
class (FormOf e ~ 'Polynomial) => PolyHFunctor (e :: Effect)

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