{-# LANGUAGE TemplateHaskell #-}

-- | Description: The 'Input' effect
module Polysemy.Input
  ( -- * Effect
    Input (..)

    -- * Actions
  , input
  , inputs

    -- * Interpretations
  , runInputConst
  , runInputList
  , runInputSem
  ) where

import Data.Foldable (for_)
import Data.List (uncons)
import Polysemy
import Polysemy.State

------------------------------------------------------------------------------
-- | An effect which can provide input to an application. Useful for dealing
-- with streaming input.
data Input i m a where
  -- | Get the next available message.
  Input :: Input i m i

makeSem ''Input

-- | Apply a function to an input, cf. 'Polysemy.Reader.asks'
inputs :: forall i j r. Member (Input i) r => (i -> j) -> Sem r j
inputs :: forall i j (r :: EffectRow).
Member (Input i) r =>
(i -> j) -> Sem r j
inputs i -> j
f = i -> j
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
{-# INLINABLE inputs #-}

------------------------------------------------------------------------------
-- | Run an 'Input' effect by always giving back the same value.
runInputConst :: i -> Sem (Input i ': r) a -> Sem r a
runInputConst :: forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst i
c = 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 i (Sem rInitial) x
Input -> forall (f :: * -> *) a. Applicative f => a -> f a
pure i
c
{-# INLINE runInputConst #-}


------------------------------------------------------------------------------
-- | Run an 'Input' effect by providing a different element of a list each
-- time. Returns 'Nothing' after the list is exhausted.
runInputList
    :: [i]
    -> Sem (Input (Maybe i) ': r) a
    -> Sem r a
runInputList :: forall i (r :: EffectRow) a.
[i] -> Sem (Input (Maybe i) : r) a -> Sem r a
runInputList [i]
is = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (r :: EffectRow) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState [i]
is forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e1 :: Effect) (e2 :: Effect) (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret
  (\case
      Input (Maybe i) (Sem rInitial) x
Input -> do
        Maybe (i, [i])
s <- forall s a (r :: EffectRow).
Member (State s) r =>
(s -> a) -> Sem r a
gets forall a. [a] -> Maybe (a, [a])
uncons
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (i, [i])
s forall a b. (a -> b) -> a -> b
$ forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (i, [i])
s
  )
{-# INLINE runInputList #-}


------------------------------------------------------------------------------
-- | Runs an 'Input' effect by evaluating a monadic action for each request.
runInputSem :: forall i r a. Sem r i -> Sem (Input i ': r) a -> Sem r a
runInputSem :: forall i (r :: EffectRow) a.
Sem r i -> Sem (Input i : r) a -> Sem r a
runInputSem Sem r i
m = 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 i (Sem rInitial) x
Input -> Sem r i
m
{-# INLINE runInputSem #-}