{-# LANGUAGE TemplateHaskell #-}

-- | Something for converting polysemy actions into IO actions
module Calamity.Internal.RunIntoIO
    ( IntoIO(..)
    , runIntoIOFinal
    , intoIO
    , bindSemToIO ) where

import           Data.Functor

import qualified Polysemy                         as P
import qualified Polysemy.Final                   as P

data IntoIO p r m a where
  IntoIO :: (p -> m r) -> IntoIO p r m (p -> IO (Maybe r))

runIntoIOFinal :: forall r p b a. P.Member (P.Final IO) r => P.Sem (IntoIO p b ': r) a -> P.Sem r a
runIntoIOFinal :: Sem (IntoIO p b : r) a -> Sem r a
runIntoIOFinal = (forall x (n :: * -> *). IntoIO p b n x -> Strategic IO n x)
-> Sem (IntoIO p b : r) a -> Sem r a
forall (m :: * -> *) (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Member (Final m) r =>
(forall x (n :: * -> *). e n x -> Strategic m n x)
-> Sem (e : r) a -> Sem r a
P.interpretFinal ((forall x (n :: * -> *). IntoIO p b n x -> Strategic IO n x)
 -> Sem (IntoIO p b : r) a -> Sem r a)
-> (forall x (n :: * -> *). IntoIO p b n x -> Strategic IO n x)
-> Sem (IntoIO p b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  IntoIO m -> do
    f ()
istate <- Sem (WithStrategy IO f n) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
P.getInitialStateS
    f p -> IO (f b)
m' <- (p -> n b) -> Sem (WithStrategy IO f n) (f p -> IO (f b))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
P.bindS p -> n b
m
    Inspector f
ins <- Sem (WithStrategy IO f n) (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
P.getInspectorS
    IO (p -> IO (Maybe b)) -> Sem (WithStrategy IO f n) (IO (f x))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
P.liftS (IO (p -> IO (Maybe b)) -> Sem (WithStrategy IO f n) (IO (f x)))
-> IO (p -> IO (Maybe b)) -> Sem (WithStrategy IO f n) (IO (f x))
forall a b. (a -> b) -> a -> b
$ (p -> IO (Maybe b)) -> IO (p -> IO (Maybe b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\x :: p
x -> Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
P.inspect Inspector f
ins (f b -> Maybe b) -> IO (f b) -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f p -> IO (f b)
m' (f ()
istate f () -> p -> f p
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> p
x))

P.makeSem ''IntoIO

bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a))
bindSemToIO :: (p -> Sem r a) -> Sem r (p -> IO (Maybe a))
bindSemToIO f :: p -> Sem r a
f = Sem (IntoIO p a : r) (p -> IO (Maybe a))
-> Sem r (p -> IO (Maybe a))
forall (r :: [(* -> *) -> * -> *]) p b a.
Member (Final IO) r =>
Sem (IntoIO p b : r) a -> Sem r a
runIntoIOFinal Sem (IntoIO p a : r) (p -> IO (Maybe a))
go
  where go :: P.Sem (IntoIO p a ': r) (p -> IO (Maybe a))
        go :: Sem (IntoIO p a : r) (p -> IO (Maybe a))
go = (p -> Sem (IntoIO p a : r) a)
-> Sem (IntoIO p a : r) (p -> IO (Maybe a))
forall p r (r :: [(* -> *) -> * -> *]).
MemberWithError (IntoIO p r) r =>
(p -> Sem r r) -> Sem r (p -> IO (Maybe r))
intoIO (Sem r a -> Sem (IntoIO p a : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
P.raise (Sem r a -> Sem (IntoIO p a : r) a)
-> (p -> Sem r a) -> p -> Sem (IntoIO p a : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Sem r a
f)