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

-- SPDX-License-Identifier: MPL-2.0

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

Realizes [@unliftio@](https://hackage.haskell.org/package/unliftio) in the form of higher-order effects.
-}
module Data.Effect.Unlift (
    module Data.Effect.Unlift,
    UnliftBase (..),
    UnliftIO,
)
where

import Control.Effect (sendAt)
import Control.Effect.Interpret (runEff)
import Data.Effect (Emb (Emb), UnliftBase (WithRunInBase), UnliftIO)
import UnliftIO qualified as IO

makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''UnliftBase

pattern WithRunInIO :: (f ~> IO -> IO a) -> UnliftIO f a
pattern $mWithRunInIO :: forall {r} {f :: * -> *} {a}.
UnliftIO f a -> (((f ~> IO) -> IO a) -> r) -> ((# #) -> r) -> r
$bWithRunInIO :: forall (f :: * -> *) a. ((f ~> IO) -> IO a) -> UnliftIO f a
WithRunInIO f = WithRunInBase f
{-# COMPLETE WithRunInIO #-}

withRunInIO
    :: forall es ff a c
     . (UnliftIO :> es, Free c ff)
    => (Eff ff es ~> IO -> IO a)
    -> Eff ff es a
withRunInIO :: forall (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(UnliftIO :> es, Free c ff) =>
((Eff ff es ~> IO) -> IO a) -> Eff ff es a
withRunInIO = ((forall x. Eff ff es x -> IO x) -> IO a) -> Eff ff es a
forall (b :: * -> *) a (f :: * -> *) (es :: [Effect])
       (ff :: Effect) (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, UnliftBase b :> es) =>
((forall x. f x -> b x) -> b a) -> f a
withRunInBase
{-# INLINE withRunInIO #-}

runUnliftBase :: forall b ff a c. (c b, Free c ff) => Eff ff '[UnliftBase b, Emb b] a -> b a
runUnliftBase :: forall (b :: * -> *) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(c b, Free c ff) =>
Eff ff '[UnliftBase b, Emb b] a -> b a
runUnliftBase =
    Eff ff '[Emb b] a -> b a
forall (c :: (* -> *) -> Constraint) (ff :: Effect) (f :: * -> *)
       a.
(Free c ff, c f) =>
Eff ff '[Emb f] a -> f a
runEff (Eff ff '[Emb b] a -> b a)
-> (Eff ff '[UnliftBase b, Emb b] a -> Eff ff '[Emb b] a)
-> Eff ff '[UnliftBase b, Emb b] a
-> b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnliftBase b ~~> Eff ff '[Emb b])
-> Eff ff '[UnliftBase b, Emb b] a -> Eff ff '[Emb b] a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \(WithRunInBase (forall x. Eff ff '[Emb b] x -> b x) -> b x
f) ->
        forall (i :: Nat) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownIndex i es, Free c ff) =>
At i es (Eff ff es) a -> Eff ff es a
sendAt @0 (At 0 '[Emb b] (Eff ff '[Emb b]) x -> Eff ff '[Emb b] x)
-> At 0 '[Emb b] (Eff ff '[Emb b]) x -> Eff ff '[Emb b] x
forall a b. (a -> b) -> a -> b
$ b x -> Emb b (Eff ff '[Emb b]) x
forall (e :: * -> *) (f :: * -> *) a. e a -> Emb e f a
Emb (b x -> Emb b (Eff ff '[Emb b]) x)
-> b x -> Emb b (Eff ff '[Emb b]) x
forall a b. (a -> b) -> a -> b
$ (forall x. Eff ff '[Emb b] x -> b x) -> b x
f Eff ff '[Emb b] x -> b x
forall x. Eff ff '[Emb b] x -> b x
forall (c :: (* -> *) -> Constraint) (ff :: Effect) (f :: * -> *)
       a.
(Free c ff, c f) =>
Eff ff '[Emb f] a -> f a
runEff
{-# INLINE runUnliftBase #-}

runUnliftIO :: (IO.MonadUnliftIO m, Free c ff, c m) => Eff ff '[UnliftIO, Emb m] a -> m a
runUnliftIO :: forall (m :: * -> *) (c :: (* -> *) -> Constraint) (ff :: Effect)
       a.
(MonadUnliftIO m, Free c ff, c m) =>
Eff ff '[UnliftIO, Emb m] a -> m a
runUnliftIO =
    Eff ff '[Emb m] a -> m a
forall (c :: (* -> *) -> Constraint) (ff :: Effect) (f :: * -> *)
       a.
(Free c ff, c f) =>
Eff ff '[Emb f] a -> f a
runEff (Eff ff '[Emb m] a -> m a)
-> (Eff ff '[UnliftIO, Emb m] a -> Eff ff '[Emb m] a)
-> Eff ff '[UnliftIO, Emb m] a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnliftIO ~~> Eff ff '[Emb m])
-> Eff ff '[UnliftIO, Emb m] a -> Eff ff '[Emb m] a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \(WithRunInBase (forall x. Eff ff '[Emb m] x -> IO x) -> IO x
f) ->
        forall (i :: Nat) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownIndex i es, Free c ff) =>
At i es (Eff ff es) a -> Eff ff es a
sendAt @0 (At 0 '[Emb m] (Eff ff '[Emb m]) x -> Eff ff '[Emb m] x)
-> At 0 '[Emb m] (Eff ff '[Emb m]) x -> Eff ff '[Emb m] x
forall a b. (a -> b) -> a -> b
$ m x -> Emb m (Eff ff '[Emb m]) x
forall (e :: * -> *) (f :: * -> *) a. e a -> Emb e f a
Emb (m x -> Emb m (Eff ff '[Emb m]) x)
-> m x -> Emb m (Eff ff '[Emb m]) x
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> IO a) -> IO x) -> m x
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
IO.withRunInIO \forall a. m a -> IO a
run -> (forall x. Eff ff '[Emb m] x -> IO x) -> IO x
f ((forall x. Eff ff '[Emb m] x -> IO x) -> IO x)
-> (forall x. Eff ff '[Emb m] x -> IO x) -> IO x
forall a b. (a -> b) -> a -> b
$ m x -> IO x
forall a. m a -> IO a
run (m x -> IO x)
-> (Eff ff '[Emb m] x -> m x) -> Eff ff '[Emb m] x -> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff ff '[Emb m] x -> m x
forall (c :: (* -> *) -> Constraint) (ff :: Effect) (f :: * -> *)
       a.
(Free c ff, c f) =>
Eff ff '[Emb f] a -> f a
runEff
{-# INLINE runUnliftIO #-}