{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- |
--   Module     : Polysemy.Uncontrolled
--   License    : MIT
--   Stability  : experimental
--
-- `Uncontrolled` is the dual of `Methodology`. Where a `Methodology b c`
-- represents a way to turn `b` into `c` in a controlled decomposition,
-- `Uncontrolled` represents a purely unknown side effect - that materialises
-- `b`s out of nowhere, and sends `c`s into the void where we have no knowledge
-- of what happens to them. This is equivalent to the combination of `Input`
-- and `Output` considered as a single unit.
module Polysemy.Uncontrolled
  ( -- * Definition
    Uncontrolled (..),
    send,
    receive,

    -- * Eliminators
    runUncontrolledAsState,
    runUncontrolledAsStateSem,
    runUncontrolledAsInputOutput,

    -- * Adapters
    adaptUncontrolledPure,
    adaptUncontrolledSem,

    -- * Coeliminators
    runInputAsUncontrolled,
    runOutputAsUncontrolled,
    runMethodologyAsUncontrolled,
  )
where

import Polysemy
import Polysemy.Input
import Polysemy.Methodology
import Polysemy.Output
import Polysemy.State

-- | An `Uncontrolled` generalises an unmanaged side effect.
--
-- @since 0.1.0.0
data Uncontrolled c b m a where
  Send :: c -> Uncontrolled c b m ()
  Receive :: Uncontrolled c b m b

makeSem ''Uncontrolled

-- | Run an `Uncontrolled` as `State`, using a neutral element and accessors.
--
-- @since 0.1.0.0
runUncontrolledAsState :: forall s b c r a. Members '[State s] r => (c -> s) -> (s -> b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsState :: forall s b c (r :: EffectRow) a.
Members '[State s] r =>
(c -> s) -> (s -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsState c -> s
f s -> b
g = forall s b c (r :: EffectRow) a.
Members '[State s] r =>
(c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsStateSem (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> s
f) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> b
g)
{-# INLINE runUncontrolledAsState #-}

-- | Like `runUncontrolledAsState`, but uses monadic accessors.
--
-- @since 0.1.0.0
runUncontrolledAsStateSem :: forall s b c r a. Members '[State s] r => (c -> Sem r s) -> (s -> Sem r b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsStateSem :: forall s b c (r :: EffectRow) a.
Members '[State s] r =>
(c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsStateSem c -> Sem r s
f s -> Sem r b
g = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Send c
c -> c -> Sem r s
f c
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put
  Uncontrolled c b (Sem rInitial) x
Receive -> forall s (r :: EffectRow). Member (State s) r => Sem r s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Sem r b
g
{-# INLINE runUncontrolledAsStateSem #-}

-- | Run an `Uncontrolled` as an `Input`/`Output` pair.
--
-- @since 0.1.0.0
runUncontrolledAsInputOutput :: Members '[Input b, Output c] r => Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsInputOutput :: forall b c (r :: EffectRow) a.
Members '[Input b, Output c] r =>
Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsInputOutput = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Send c
c -> forall o (r :: EffectRow). Member (Output o) r => o -> Sem r ()
output c
c
  Uncontrolled c b (Sem rInitial) x
Receive -> forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
{-# INLINE runUncontrolledAsInputOutput #-}

-- | Run an `Uncontrolled` as another kind of `Uncontrolled`, using pure functions to dimap from one to the other.
--
-- @since 0.1.0.0
adaptUncontrolledPure :: Members '[Uncontrolled c' b'] r => (c -> c') -> (b' -> b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
adaptUncontrolledPure :: forall c' b' (r :: EffectRow) c b a.
Members '[Uncontrolled c' b'] r =>
(c -> c') -> (b' -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledPure c -> c'
f b' -> b
g = forall c b c' b' (r :: EffectRow) a.
Members '[Uncontrolled c' b'] r =>
(c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledSem (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c'
f) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. b' -> b
g)
{-# INLINE adaptUncontrolledPure #-}

-- | Like `adaptUncontrolledPure`, but with monadic adapters.
--
-- @since 0.1.0.0
adaptUncontrolledSem :: forall c b c' b' r a. Members '[Uncontrolled c' b'] r => (c -> Sem r c') -> (b' -> Sem r b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
adaptUncontrolledSem :: forall c b c' b' (r :: EffectRow) a.
Members '[Uncontrolled c' b'] r =>
(c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledSem c -> Sem r c'
f b' -> Sem r b
g = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Send c
c -> c -> Sem r c'
f c
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c b (r :: EffectRow).
Member (Uncontrolled c b) r =>
c -> Sem r ()
send @c' @b'
  Uncontrolled c b (Sem rInitial) x
Receive -> forall c b (r :: EffectRow). Member (Uncontrolled c b) r => Sem r b
receive @c' @b' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b' -> Sem r b
g
{-# INLINE adaptUncontrolledSem #-}

-- | Run an `Input` as one side of an `Uncontrolled`.
--
-- @since 0.1.0.0
runInputAsUncontrolled :: forall c b r a. Members '[Uncontrolled c b] r => Sem (Input b ': r) a -> Sem r a
runInputAsUncontrolled :: forall c b (r :: EffectRow) a.
Members '[Uncontrolled c b] r =>
Sem (Input b : r) a -> Sem r a
runInputAsUncontrolled = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Input b (Sem rInitial) x
Input -> forall c b (r :: EffectRow). Member (Uncontrolled c b) r => Sem r b
receive @c @b
{-# INLINE runInputAsUncontrolled #-}

-- | Run an `Output` as one side of an `Uncontrolled`.
--
-- @since 0.1.0.0
runOutputAsUncontrolled :: forall c b r a. Members '[Uncontrolled c b] r => Sem (Output c ': r) a -> Sem r a
runOutputAsUncontrolled :: forall c b (r :: EffectRow) a.
Members '[Uncontrolled c b] r =>
Sem (Output c : r) a -> Sem r a
runOutputAsUncontrolled = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Output c
c -> forall c b (r :: EffectRow).
Member (Uncontrolled c b) r =>
c -> Sem r ()
send @c @b c
c
{-# INLINE runOutputAsUncontrolled #-}

-- | Run a `Methodology` as an `Uncontrolled` pure side effect.
--
-- @since 0.1.0.0
runMethodologyAsUncontrolled :: forall c b r a. Members '[Uncontrolled b c] r => Sem (Methodology b c ': r) a -> Sem r a
runMethodologyAsUncontrolled :: forall c b (r :: EffectRow) a.
Members '[Uncontrolled b c] r =>
Sem (Methodology b c : r) a -> Sem r a
runMethodologyAsUncontrolled = forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Process b
b -> forall c b (r :: EffectRow).
Member (Uncontrolled c b) r =>
c -> Sem r ()
send @b @c b
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall c b (r :: EffectRow). Member (Uncontrolled c b) r => Sem r b
receive @b @c
{-# INLINE runMethodologyAsUncontrolled #-}