{-# 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 evil 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.
--
-- This exists for symmetry with `Methodology` and out of curiosity, but should
-- be considered extremely dangerous. `Uncontrolled` can only ever be
-- reinterpreted as an equally or more severe side effect than the context in
-- which it's introduced. For experimentation though, this module might be fun
-- to see how much evil you can get away with.
--
-- There is a simple interpretation in the form of `runUncontrolledAsState`, as
-- well as ways of getting between `Uncontrolled` and `Input`/`Output`.
-- Combined with `teeMethodology` and `plugMethodology`, this may give you a
-- way to teleport state around your architecture.
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 :: (c -> s) -> (s -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsState c -> s
f s -> b
g = (c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
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 (s -> Sem r s
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Sem r s) -> (c -> s) -> c -> Sem r s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> s
f) (b -> Sem r b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Sem r b) -> (s -> b) -> s -> Sem r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> b
g)
{-# INLINE runUncontrolledAsState #-}

-- | Like `runUncontrolledAsState`, but uses monadic accessors. Using this would be completely insane. ;)
--
-- @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 :: (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 (rInitial :: [(* -> *) -> * -> *]) x.
 Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Uncontrolled c b (Sem rInitial) x -> Sem r x)
 -> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Send c -> c -> Sem r s
f c
c Sem r s -> (s -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
s -> Sem r ()
put
  Uncontrolled c b (Sem rInitial) x
Receive -> Sem r s
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
Sem r s
get Sem r s -> (s -> Sem r b) -> Sem r b
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 :: Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsInputOutput = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Uncontrolled c b (Sem rInitial) x -> Sem r x)
 -> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Send c -> c -> Sem r ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (Output o) r =>
o -> Sem r ()
output c
c
  Uncontrolled c b (Sem rInitial) x
Receive -> Sem r x
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (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 :: (c -> c') -> (b' -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledPure c -> c'
f b' -> b
g = (c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
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 (c' -> Sem r c'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c' -> Sem r c') -> (c -> c') -> c -> Sem r c'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c'
f) (b -> Sem r b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Sem r b) -> (b' -> b) -> b' -> Sem r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b' -> b
g)
{-# INLINE adaptUncontrolledPure #-}

-- | Like `adaptUncontrolledPure`, but with monadic adapters. If you use this I have no idea what you're trying to accomplish.
--
-- @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 :: (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 (rInitial :: [(* -> *) -> * -> *]) x.
 Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Uncontrolled c b (Sem rInitial) x -> Sem r x)
 -> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Send c -> c -> Sem r c'
f c
c Sem r c' -> (c' -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c' b') r =>
c' -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
c -> Sem r ()
send @c' @b'
  Uncontrolled c b (Sem rInitial) x
Receive -> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c' b') r =>
Sem r b'
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
receive @c' @b' Sem r b' -> (b' -> Sem r b) -> Sem r 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 :: Sem (Input b : r) a -> Sem r a
runInputAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Input b (Sem rInitial) x -> Sem r x)
-> Sem (Input b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Input b (Sem rInitial) x -> Sem r x)
 -> Sem (Input b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Input b (Sem rInitial) x -> Sem r x)
-> Sem (Input b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Input b (Sem rInitial) x
Input -> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (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 :: Sem (Output c : r) a -> Sem r a
runOutputAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Output c (Sem rInitial) x -> Sem r x)
-> Sem (Output c : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Output c (Sem rInitial) x -> Sem r x)
 -> Sem (Output c : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Output c (Sem rInitial) x -> Sem r x)
-> Sem (Output c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Output c -> c -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (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 :: Sem (Methodology b c : r) a -> Sem r a
runMethodologyAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Methodology b c (Sem rInitial) x -> Sem r x)
-> Sem (Methodology b c : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Methodology b c (Sem rInitial) x -> Sem r x)
 -> Sem (Methodology b c : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Methodology b c (Sem rInitial) x -> Sem r x)
-> Sem (Methodology b c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Process b -> b -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
c -> Sem r ()
send @b @c b
b Sem r () -> Sem r c -> Sem r c
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled b c) r =>
Sem r c
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
receive @b @c
{-# INLINE runMethodologyAsUncontrolled #-}