{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module      :   Grisette.Lib.Control.Monad.Coroutine.SuspensionFunctors
-- Copyright   :   (c) Sirui Lu 2021-2023
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Lib.Control.Monad.Coroutine.SuspensionFunctors
  ( mrgYield,
    mrgAwait,
    mrgRequest,
  )
where

import Control.Monad.Coroutine
import Control.Monad.Coroutine.SuspensionFunctors
import Grisette.Core
import Grisette.Lib.Control.Monad
import Grisette.Lib.Control.Monad.Coroutine

instance (Mergeable x, Mergeable y) => Mergeable (Yield x y) where
  rootStrategy :: MergingStrategy (Yield x y)
rootStrategy = forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy forall x y. x -> y -> Yield x y
Yield (\(Yield x
x y
y) -> (x
x, y
y)) forall a. Mergeable a => MergingStrategy a
rootStrategy forall a. Mergeable a => MergingStrategy a
rootStrategy

instance (Mergeable x) => Mergeable1 (Yield x) where
  liftRootStrategy :: forall a. MergingStrategy a -> MergingStrategy (Yield x a)
liftRootStrategy = forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy forall x y. x -> y -> Yield x y
Yield (\(Yield x
x a
y) -> (x
x, a
y)) forall a. Mergeable a => MergingStrategy a
rootStrategy

instance (Mergeable x, Mergeable y) => Mergeable (Await x y) where
  rootStrategy :: MergingStrategy (Await x y)
rootStrategy = forall a b.
MergingStrategy a -> (a -> b) -> (b -> a) -> MergingStrategy b
wrapStrategy forall a. Mergeable a => MergingStrategy a
rootStrategy forall x y. (x -> y) -> Await x y
Await (\(Await x -> y
x) -> x -> y
x)

instance (Mergeable x) => Mergeable1 (Await x) where
  liftRootStrategy :: forall a. MergingStrategy a -> MergingStrategy (Await x a)
liftRootStrategy MergingStrategy a
m = forall a b.
MergingStrategy a -> (a -> b) -> (b -> a) -> MergingStrategy b
wrapStrategy (forall (u :: * -> *) a.
Mergeable1 u =>
MergingStrategy a -> MergingStrategy (u a)
liftRootStrategy MergingStrategy a
m) forall x y. (x -> y) -> Await x y
Await (\(Await x -> a
x) -> x -> a
x)

instance
  (Mergeable req, Mergeable res, Mergeable x) =>
  Mergeable (Request req res x)
  where
  rootStrategy :: MergingStrategy (Request req res x)
rootStrategy = forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy forall request response x.
request -> (response -> x) -> Request request response x
Request (\(Request req
x res -> x
y) -> (req
x, res -> x
y)) forall a. Mergeable a => MergingStrategy a
rootStrategy forall a. Mergeable a => MergingStrategy a
rootStrategy

instance (Mergeable req, Mergeable res) => Mergeable1 (Request req res) where
  liftRootStrategy :: forall a. MergingStrategy a -> MergingStrategy (Request req res a)
liftRootStrategy MergingStrategy a
m = forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy forall request response x.
request -> (response -> x) -> Request request response x
Request (\(Request req
x res -> a
y) -> (req
x, res -> a
y)) forall a. Mergeable a => MergingStrategy a
rootStrategy (forall (u :: * -> *) a.
Mergeable1 u =>
MergingStrategy a -> MergingStrategy (u a)
liftRootStrategy MergingStrategy a
m)

-- | Symbolic version of 'Control.Monad.Coroutine.SuspensionFunctors.yield',
-- the result would be merged and propagate the mergeable knowledge.
mrgYield :: (MonadUnion m, Mergeable x) => x -> Coroutine (Yield x) m ()
mrgYield :: forall (m :: * -> *) x.
(MonadUnion m, Mergeable x) =>
x -> Coroutine (Yield x) m ()
mrgYield x
x = forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend (forall x y. x -> y -> Yield x y
Yield x
x forall a b. (a -> b) -> a -> b
$ forall (u :: * -> *) a. (MonadUnion u, Mergeable a) => a -> u a
mrgReturn ())
{-# INLINEABLE mrgYield #-}

-- | Symbolic version of 'Control.Monad.Coroutine.SuspensionFunctors.await',
-- the result would be merged and propagate the mergeable knowledge.
mrgAwait :: (MonadUnion m, Mergeable x) => Coroutine (Await x) m x
mrgAwait :: forall (m :: * -> *) x.
(MonadUnion m, Mergeable x) =>
Coroutine (Await x) m x
mrgAwait = forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend (forall x y. (x -> y) -> Await x y
Await forall (u :: * -> *) a. (MonadUnion u, Mergeable a) => a -> u a
mrgReturn)
{-# INLINEABLE mrgAwait #-}

-- | Symbolic version of 'Control.Monad.Coroutine.SuspensionFunctors.request',
-- the result would be merged and propagate the mergeable knowledge.
mrgRequest :: (MonadUnion m, Mergeable x, Mergeable y) => x -> Coroutine (Request x y) m y
mrgRequest :: forall (m :: * -> *) x y.
(MonadUnion m, Mergeable x, Mergeable y) =>
x -> Coroutine (Request x y) m y
mrgRequest x
x = forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend (forall request response x.
request -> (response -> x) -> Request request response x
Request x
x forall (u :: * -> *) a. (MonadUnion u, Mergeable a) => a -> u a
mrgReturn)
{-# INLINEABLE mrgRequest #-}