{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}

-- SPDX-License-Identifier: MPL-2.0

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

This module defines the t'Eff' monad and related fundamental types and functions.
Please refer to the documentation of the [top-level module]("Control.Monad.Hefty").
-}
module Control.Monad.Hefty.Types where

import Control.Effect (Free)
import Control.Effect qualified as D
import Data.Effect (Effect)
import Data.FTCQueue (FTCQueue, ViewL (..), tsingleton, tviewl, (><), (|>))
import Data.Kind (Type)

data Freer f a
    = -- | A pure value.
      Val a
    | -- | An effectful operation.
      forall x. Op
        (f x)
        (FTCQueue (Freer f) x a)
        -- ^ the continuation of the operation.

type Eff = D.Eff Freer

type AlgHandler (e :: Effect) m n (ans :: Type) = forall x. e m x -> (x -> n ans) -> n ans

instance Functor (Freer f) where
    fmap :: forall a b. (a -> b) -> Freer f a -> Freer f b
fmap a -> b
f = \case
        Val a
x -> b -> Freer f b
forall (f :: * -> *) a. a -> Freer f a
Val (a -> b
f a
x)
        Op f x
u FTCQueue (Freer f) x a
q -> f x -> FTCQueue (Freer f) x b -> Freer f b
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f x
u (FTCQueue (Freer f) x a
q FTCQueue (Freer f) x a
-> (a -> Freer f b) -> FTCQueue (Freer f) x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Freer f b
forall (f :: * -> *) a. a -> Freer f a
Val (b -> Freer f b) -> (a -> b) -> a -> Freer f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
    {-# INLINE fmap #-}

instance Applicative (Freer f) where
    pure :: forall a. a -> Freer f a
pure = a -> Freer f a
forall (f :: * -> *) a. a -> Freer f a
Val
    {-# INLINE pure #-}

    Val a -> b
f <*> :: forall a b. Freer f (a -> b) -> Freer f a -> Freer f b
<*> Val a
x = b -> Freer f b
forall (f :: * -> *) a. a -> Freer f a
Val (b -> Freer f b) -> b -> Freer f b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
    Val a -> b
f <*> Op f x
u FTCQueue (Freer f) x a
q = f x -> FTCQueue (Freer f) x b -> Freer f b
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f x
u (FTCQueue (Freer f) x a
q FTCQueue (Freer f) x a
-> (a -> Freer f b) -> FTCQueue (Freer f) x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Freer f b
forall (f :: * -> *) a. a -> Freer f a
Val (b -> Freer f b) -> (a -> b) -> a -> Freer f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
    Op f x
u FTCQueue (Freer f) x (a -> b)
q <*> Freer f a
m = f x -> FTCQueue (Freer f) x b -> Freer f b
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f x
u (FTCQueue (Freer f) x (a -> b)
q FTCQueue (Freer f) x (a -> b)
-> ((a -> b) -> Freer f b) -> FTCQueue (Freer f) x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> ((a -> b) -> Freer f a -> Freer f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Freer f a
m))
    {-# INLINE (<*>) #-}

instance Monad (Freer f) where
    Freer f a
m >>= :: forall a b. Freer f a -> (a -> Freer f b) -> Freer f b
>>= a -> Freer f b
k = case Freer f a
m of
        Val a
x -> a -> Freer f b
k a
x
        Op f x
e FTCQueue (Freer f) x a
q -> f x -> FTCQueue (Freer f) x b -> Freer f b
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f x
e (FTCQueue (Freer f) x a
q FTCQueue (Freer f) x a
-> (a -> Freer f b) -> FTCQueue (Freer f) x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> a -> Freer f b
k)
    {-# INLINE (>>=) #-}

instance Free Monad Freer where
    liftFree :: forall (f :: * -> *) a. f a -> Freer f a
liftFree f a
f = f a -> FTCQueue (Freer f) a a -> Freer f a
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f a
f ((a -> Freer f a) -> FTCQueue (Freer f) a a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton a -> Freer f a
forall a. a -> Freer f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    runFree :: forall (g :: * -> *) (f :: * -> *) a.
Monad g =>
(forall x. f x -> g x) -> Freer f a -> g a
runFree forall x. f x -> g x
i = Freer f a -> g a
loop
      where
        loop :: Freer f a -> g a
loop = \case
            Val a
x -> a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
            Op f x
f FTCQueue (Freer f) x a
q -> f x -> g x
forall x. f x -> g x
i f x
f g x -> (x -> g a) -> g a
forall a b. g a -> (a -> g b) -> g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Freer f a -> g a
loop (Freer f a -> g a) -> (x -> Freer f a) -> x -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FTCQueue (Freer f) x a -> x -> Freer f a
forall (f :: * -> *) a b. FTCQueue (Freer f) a b -> a -> Freer f b
qApp FTCQueue (Freer f) x a
q

    {-# INLINE liftFree #-}
    {-# INLINE runFree #-}

-- | Applies a value to a Kleisli arrow in 'FTCQueue' representation.
qApp :: FTCQueue (Freer f) a b -> a -> Freer f b
qApp :: forall (f :: * -> *) a b. FTCQueue (Freer f) a b -> a -> Freer f b
qApp FTCQueue (Freer f) a b
q' a
x = case FTCQueue (Freer f) a b -> ViewL (Freer f) a b
forall (m :: * -> *) a b. FTCQueue m a b -> ViewL m a b
tviewl FTCQueue (Freer f) a b
q' of
    TOne a -> Freer f b
k -> a -> Freer f b
k a
x
    a -> Freer f x
k :| FTCQueue (Freer f) x b
t -> case a -> Freer f x
k a
x of
        Val x
y -> FTCQueue (Freer f) x b -> x -> Freer f b
forall (f :: * -> *) a b. FTCQueue (Freer f) a b -> a -> Freer f b
qApp FTCQueue (Freer f) x b
t x
y
        Op f x
u FTCQueue (Freer f) x x
q -> f x -> FTCQueue (Freer f) x b -> Freer f b
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op f x
u (FTCQueue (Freer f) x x
q FTCQueue (Freer f) x x
-> FTCQueue (Freer f) x b -> FTCQueue (Freer f) x b
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
>< FTCQueue (Freer f) x b
t)