{-# LANGUAGE AllowAmbiguousTypes #-}

-- | Description: The 'Bundle' effect for bundling effects
module Polysemy.Bundle
  ( -- * Effect
    Bundle (..)
    -- * Actions
  , sendBundle
  , injBundle
    -- * Interpretations
  , runBundle
  , subsumeBundle
    -- * Miscellaneous
  ) where

import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Union
import Polysemy.Internal.Bundle (subsumeMembership)
import Polysemy.Internal.Sing (KnownList (singList))

------------------------------------------------------------------------------
-- | An effect for collecting multiple effects into one effect.
--
-- Useful for effect newtypes -- effects defined through creating a newtype
-- over an existing effect, and then defining actions and interpretations on
-- the newtype by using 'rewrite' and 'transform'.
--
-- By making a newtype of 'Bundle', it's possible to wrap multiple effects in
-- one newtype.
data Bundle r m a where
  Bundle :: ElemOf e r -> e m a -> Bundle r m a

------------------------------------------------------------------------------
-- | Injects an effect into a 'Bundle'. Useful together with 'transform'.
injBundle :: forall e r m a. Member e r => e m a -> Bundle r m a
injBundle :: forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
e m a -> Bundle r m a
injBundle = forall {k} {k} (e :: k -> k -> *) (r :: [k -> k -> *]) (m :: k)
       (a :: k).
ElemOf e r -> e m a -> Bundle r m a
Bundle forall (e :: Effect) (r :: EffectRow). Member e r => ElemOf e r
membership
{-# INLINE injBundle #-}

------------------------------------------------------------------------------
-- | Send uses of an effect to a 'Bundle' containing that effect.
sendBundle
  :: forall e r' r a
   . (Member e r', Member (Bundle r') r)
  => Sem (e ': r) a
  -> Sem r a
sendBundle :: forall (e :: Effect) (r' :: EffectRow) (r :: EffectRow) a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
sendBundle = forall (r :: EffectRow) (r' :: EffectRow) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem forall a b. (a -> b) -> a -> b
$ \Union (e : r) (Sem (e : r)) x
u -> case forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (e : r) (Sem (e : r)) x
u of
  Right (Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
    forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
Weaving e m a -> Union r m a
injWeaving forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) (e :: Effect) (rInitial :: EffectRow) a
       resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving (forall {k} {k} (e :: k -> k -> *) (r :: [k -> k -> *]) (m :: k)
       (a :: k).
ElemOf e r -> e m a -> Bundle r m a
Bundle (forall (e :: Effect) (r :: EffectRow). Member e r => ElemOf e r
membership @e @r') e (Sem rInitial) a
e) f ()
s (forall (e :: Effect) (r' :: EffectRow) (r :: EffectRow) a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
sendBundle @e @r' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv) f a -> x
ex forall x. f x -> Maybe x
ins
  Left Union r (Sem (e : r)) x
g -> forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist (forall (e :: Effect) (r' :: EffectRow) (r :: EffectRow) a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
sendBundle @e @r') Union r (Sem (e : r)) x
g
{-# INLINE sendBundle #-}

------------------------------------------------------------------------------
-- | Run a @'Bundle' r@ by prepending @r@ to the effect stack.
runBundle
  :: forall r' r a
   . KnownList r'
  => Sem (Bundle r' ': r) a
  -> Sem (Append r' r) a
runBundle :: forall (r' :: EffectRow) (r :: EffectRow) a.
KnownList r' =>
Sem (Bundle r' : r) a -> Sem (Append r' r) a
runBundle = forall (r :: EffectRow) (r' :: EffectRow) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem forall a b. (a -> b) -> a -> b
$ \Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u -> forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist forall (r' :: EffectRow) (r :: EffectRow) a.
KnownList r' =>
Sem (Bundle r' : r) a -> Sem (Append r' r) a
runBundle forall a b. (a -> b) -> a -> b
$ case forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u of
  Right (Weaving (Bundle ElemOf e r'
pr e (Sem rInitial) a
e) f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
    forall (e :: Effect) (r :: EffectRow) (mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union (forall {a} (l :: [a]) (r :: [a]) (e :: a).
ElemOf e l -> ElemOf e (Append l r)
extendMembershipRight @r' @r ElemOf e r'
pr) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (e :: Effect) (rInitial :: EffectRow) a
       resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins
  Left Union r (Sem (Bundle r' : r)) x
g -> forall (l :: EffectRow) (r :: EffectRow) (m :: * -> *) a.
SList l -> Union r m a -> Union (Append l r) m a
weakenList @r' @r (forall {k} (l :: [k]). KnownList l => SList l
singList @r') Union r (Sem (Bundle r' : r)) x
g
{-# INLINE runBundle #-}

------------------------------------------------------------------------------
-- | Run a @'Bundle' r@ if the effect stack contains all effects of @r@.
subsumeBundle
  :: forall r' r a
   . Members r' r
  => Sem (Bundle r' ': r) a
  -> Sem r a
subsumeBundle :: forall (r' :: EffectRow) (r :: EffectRow) a.
Members r' r =>
Sem (Bundle r' : r) a -> Sem r a
subsumeBundle = forall (r :: EffectRow) (r' :: EffectRow) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem forall a b. (a -> b) -> a -> b
$ \Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u -> forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist forall (r' :: EffectRow) (r :: EffectRow) a.
Members r' r =>
Sem (Bundle r' : r) a -> Sem r a
subsumeBundle forall a b. (a -> b) -> a -> b
$ case forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u of
  Right (Weaving (Bundle ElemOf e r'
pr e (Sem rInitial) a
e) f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
    forall (e :: Effect) (r :: EffectRow) (mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union (forall (r :: EffectRow) (r' :: EffectRow) (e :: Effect).
Members r r' =>
ElemOf e r -> ElemOf e r'
subsumeMembership ElemOf e r'
pr) (forall (f :: * -> *) (e :: Effect) (rInitial :: EffectRow) a
       resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins)
  Left Union r (Sem (Bundle r' : r)) x
g -> Union r (Sem (Bundle r' : r)) x
g
{-# INLINE subsumeBundle #-}