{-# LANGUAGE AllowAmbiguousTypes #-}
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 :: e m a -> Bundle r m a
injBundle = ElemOf e r -> e m a -> Bundle r m a
forall k k (e :: k -> k -> *) (r :: [k -> k -> *]) (m :: k)
       (a :: k).
ElemOf e r -> e m a -> Bundle r m a
Bundle ElemOf e r
forall a (e :: a) (r :: [a]). 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 :: Sem (e : r) a -> Sem r a
sendBundle = (forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) a -> Sem r a
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 x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
 -> Sem (e : r) a -> Sem r a)
-> (forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (e : r) (Sem (e : r)) x
u -> case Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: (* -> *) -> * -> *) (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) ->
    Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
Weaving e m a -> Union r m a
injWeaving (Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x)
-> Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$
      Bundle r' (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem r (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving (Bundle r') (Sem r) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (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 (ElemOf e r' -> e (Sem rInitial) a -> Bundle r' (Sem rInitial) a
forall k k (e :: k -> k -> *) (r :: [k -> k -> *]) (m :: k)
       (a :: k).
ElemOf e r -> e m a -> Bundle r m a
Bundle (Member e r' => ElemOf e r'
forall a (e :: a) (r :: [a]). Member e r => ElemOf e r
membership @e @r') e (Sem rInitial) a
e) f ()
s (forall (r :: EffectRow) a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r' :: EffectRow) (r :: EffectRow)
       a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
sendBundle @e @r' (Sem (e : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (e : r) (f x))
-> f (Sem rInitial x)
-> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (e : r) (f x)
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 x. Sem (e : r) x -> Sem r x)
-> Union r (Sem (e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist (forall (r :: EffectRow) a.
(Member e r', Member (Bundle r') r) =>
Sem (e : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (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 :: Sem (Bundle r' : r) a -> Sem (Append r' r) a
runBundle = (forall x.
 Union (Bundle r' : r) (Sem (Bundle r' : r)) x
 -> Union (Append r' r) (Sem (Append r' r)) x)
-> Sem (Bundle r' : r) a -> Sem (Append r' r) a
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 x.
  Union (Bundle r' : r) (Sem (Bundle r' : r)) x
  -> Union (Append r' r) (Sem (Append r' r)) x)
 -> Sem (Bundle r' : r) a -> Sem (Append r' r) a)
-> (forall x.
    Union (Bundle r' : r) (Sem (Bundle r' : r)) x
    -> Union (Append r' r) (Sem (Append r' r)) x)
-> Sem (Bundle r' : r) a
-> Sem (Append r' r) a
forall a b. (a -> b) -> a -> b
$ \Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u -> (forall x. Sem (Bundle r' : r) x -> Sem (Append r' r) x)
-> Union (Append r' r) (Sem (Bundle r' : r)) x
-> Union (Append r' r) (Sem (Append r' r)) x
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
forall x. Sem (Bundle r' : r) x -> Sem (Append r' r) x
runBundle (Union (Append r' r) (Sem (Bundle r' : r)) x
 -> Union (Append r' r) (Sem (Append r' r)) x)
-> Union (Append r' r) (Sem (Bundle r' : r)) x
-> Union (Append r' r) (Sem (Append r' r)) x
forall a b. (a -> b) -> a -> b
$ case Union (Bundle r' : r) (Sem (Bundle r' : r)) x
-> Either
     (Union r (Sem (Bundle r' : r)) x)
     (Weaving (Bundle r') (Sem (Bundle r' : r)) x)
forall (e :: (* -> *) -> * -> *) (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 pr 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) ->
    ElemOf e (Append r' r)
-> Weaving e (Sem (Bundle r' : r)) x
-> Union (Append r' r) (Sem (Bundle r' : r)) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
ElemOf e r -> Weaving e m a -> Union r m a
Union (ElemOf e r' -> ElemOf e (Append r' r)
forall a (l :: [a]) (r :: [a]) (e :: a).
ElemOf e l -> ElemOf e (Append l r)
extendMembershipRight @r' @r ElemOf e r'
pr) (Weaving e (Sem (Bundle r' : r)) x
 -> Union (Append r' r) (Sem (Bundle r' : r)) x)
-> Weaving e (Sem (Bundle r' : r)) x
-> Union (Append r' r) (Sem (Bundle r' : r)) x
forall a b. (a -> b) -> a -> b
$ e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving e (Sem (Bundle r' : r)) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (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 -> SList r'
-> Union r (Sem (Bundle r' : r)) x
-> Union (Append r' r) (Sem (Bundle r' : r)) x
forall (l :: EffectRow) (r :: EffectRow) (m :: * -> *) a.
SList l -> Union r m a -> Union (Append l r) m a
weakenList @r' @r (KnownList r' => SList r'
forall a (l :: [a]). 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 :: Sem (Bundle r' : r) a -> Sem r a
subsumeBundle = (forall x.
 Union (Bundle r' : r) (Sem (Bundle r' : r)) x -> Union r (Sem r) x)
-> Sem (Bundle r' : r) a -> Sem r a
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 x.
  Union (Bundle r' : r) (Sem (Bundle r' : r)) x -> Union r (Sem r) x)
 -> Sem (Bundle r' : r) a -> Sem r a)
-> (forall x.
    Union (Bundle r' : r) (Sem (Bundle r' : r)) x -> Union r (Sem r) x)
-> Sem (Bundle r' : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (Bundle r' : r) (Sem (Bundle r' : r)) x
u -> (forall x. Sem (Bundle r' : r) x -> Sem r x)
-> Union r (Sem (Bundle r' : r)) x -> Union r (Sem r) x
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
forall x. Sem (Bundle r' : r) x -> Sem r x
subsumeBundle (Union r (Sem (Bundle r' : r)) x -> Union r (Sem r) x)
-> Union r (Sem (Bundle r' : r)) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$ case Union (Bundle r' : r) (Sem (Bundle r' : r)) x
-> Either
     (Union r (Sem (Bundle r' : r)) x)
     (Weaving (Bundle r') (Sem (Bundle r' : r)) x)
forall (e :: (* -> *) -> * -> *) (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 pr 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) ->
    ElemOf e r
-> Weaving e (Sem (Bundle r' : r)) x
-> Union r (Sem (Bundle r' : r)) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
ElemOf e r -> Weaving e m a -> Union r m a
Union (ElemOf e r' -> ElemOf e r
forall a (r :: [a]) (r' :: [a]) (e :: a).
Members r r' =>
ElemOf e r -> ElemOf e r'
subsumeMembership ElemOf e r'
pr) (e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (Bundle r' : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving e (Sem (Bundle r' : r)) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (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 #-}