{-# 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 = (x -> y -> Yield x y)
-> (Yield x y -> (x, y))
-> MergingStrategy x
-> MergingStrategy y
-> MergingStrategy (Yield x y)
forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy x -> y -> Yield x y
forall x y. x -> y -> Yield x y
Yield (\(Yield x
x y
y) -> (x
x, y
y)) MergingStrategy x
forall a. Mergeable a => MergingStrategy a
rootStrategy MergingStrategy y
forall a. Mergeable a => MergingStrategy a
rootStrategy

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

instance (Mergeable x, Mergeable y) => Mergeable (Await x y) where
  rootStrategy :: MergingStrategy (Await x y)
rootStrategy = MergingStrategy (x -> y)
-> ((x -> y) -> Await x y)
-> (Await x y -> x -> y)
-> MergingStrategy (Await x y)
forall a b.
MergingStrategy a -> (a -> b) -> (b -> a) -> MergingStrategy b
wrapStrategy MergingStrategy (x -> y)
forall a. Mergeable a => MergingStrategy a
rootStrategy (x -> y) -> Await x y
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 = MergingStrategy (x -> a)
-> ((x -> a) -> Await x a)
-> (Await x a -> x -> a)
-> MergingStrategy (Await x a)
forall a b.
MergingStrategy a -> (a -> b) -> (b -> a) -> MergingStrategy b
wrapStrategy (MergingStrategy a -> MergingStrategy (x -> a)
forall (u :: * -> *) a.
Mergeable1 u =>
MergingStrategy a -> MergingStrategy (u a)
liftRootStrategy MergingStrategy a
m) (x -> a) -> Await x a
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 = (req -> (res -> x) -> Request req res x)
-> (Request req res x -> (req, res -> x))
-> MergingStrategy req
-> MergingStrategy (res -> x)
-> MergingStrategy (Request req res x)
forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy req -> (res -> x) -> Request req res x
forall request response x.
request -> (response -> x) -> Request request response x
Request (\(Request req
x res -> x
y) -> (req
x, res -> x
y)) MergingStrategy req
forall a. Mergeable a => MergingStrategy a
rootStrategy MergingStrategy (res -> x)
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 = (req -> (res -> a) -> Request req res a)
-> (Request req res a -> (req, res -> a))
-> MergingStrategy req
-> MergingStrategy (res -> a)
-> MergingStrategy (Request req res a)
forall a b r.
(a -> b -> r)
-> (r -> (a, b))
-> MergingStrategy a
-> MergingStrategy b
-> MergingStrategy r
product2Strategy req -> (res -> a) -> Request req res a
forall request response x.
request -> (response -> x) -> Request request response x
Request (\(Request req
x res -> a
y) -> (req
x, res -> a
y)) MergingStrategy req
forall a. Mergeable a => MergingStrategy a
rootStrategy (MergingStrategy a -> MergingStrategy (res -> a)
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 = Yield x (Coroutine (Yield x) m ()) -> Coroutine (Yield x) m ()
forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend (x -> Coroutine (Yield x) m () -> Yield x (Coroutine (Yield x) m ())
forall x y. x -> y -> Yield x y
Yield x
x (Coroutine (Yield x) m () -> Yield x (Coroutine (Yield x) m ()))
-> Coroutine (Yield x) m () -> Yield x (Coroutine (Yield x) m ())
forall a b. (a -> b) -> a -> b
$ () -> Coroutine (Yield x) m ()
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 = Await x (Coroutine (Await x) m x) -> Coroutine (Await x) m x
forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend ((x -> Coroutine (Await x) m x) -> Await x (Coroutine (Await x) m x)
forall x y. (x -> y) -> Await x y
Await x -> Coroutine (Await x) m x
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 = Request x y (Coroutine (Request x y) m y)
-> Coroutine (Request x y) m y
forall (m :: * -> *) (s :: * -> *) x.
(Functor s, MonadUnion m, Mergeable x, Mergeable1 s) =>
s (Coroutine s m x) -> Coroutine s m x
mrgSuspend (x
-> (y -> Coroutine (Request x y) m y)
-> Request x y (Coroutine (Request x y) m y)
forall request response x.
request -> (response -> x) -> Request request response x
Request x
x y -> Coroutine (Request x y) m y
forall (u :: * -> *) a. (MonadUnion u, Mergeable a) => a -> u a
mrgReturn)
{-# INLINEABLE mrgRequest #-}