module Halogen.IO.Driver.Eval
  ( Renderer
  , evalF
  , evalQ
  , evalM
  , handleLifecycle
  , queueOrRun
  -- , handleIO
  )
where

import Control.Applicative.Free.Fast
import Control.Exception.Safe (finally)
import Control.Monad.Fork
import Control.Monad.Free.Church (foldF)
import Control.Monad.Parallel
import Data.Foreign
import Data.Functor.Coyoneda
import Data.Map.Strict qualified as M
import Data.NT
import HPrelude hiding (Concurrently, finally, join, runConcurrently, state)
import Halogen.Component
import Halogen.IO.Driver.State
import Halogen.Query.ChildQuery qualified as CQ
import Halogen.Query.HalogenM hiding (fork, join, kill, query, unsubscribe)
import Halogen.Query.HalogenQ qualified as HQ
import Halogen.Query.Input
import Halogen.Query.Input qualified as Input
import Halogen.Subscription qualified as HS

type Renderer m r =
  forall s f act ps i o
   . IORef (LifecycleHandlers m)
  -> IORef (DriverState m r s f act ps i o)
  -> m ()

{-# SPECIALIZE evalF :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> Input act -> IO () #-}
evalF
  :: (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)
  => Renderer m r
  -> IORef (DriverState m r s f act ps i o)
  -> Input act
  -> m ()
evalF :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o) -> Input act -> m ()
evalF Renderer m r
render IORef (DriverState m r s f act ps i o)
ref = \case
  Input.RefUpdate (Input.RefLabel Text
p) Maybe Element
el -> do
    IORef (DriverState m r s f act ps i o)
-> (DriverState m r s f act ps i o
    -> DriverState m r s f act ps i o)
-> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
atomicModifyIORef'_ IORef (DriverState m r s f act ps i o)
ref ((DriverState m r s f act ps i o -> DriverState m r s f act ps i o)
 -> m ())
-> (DriverState m r s f act ps i o
    -> DriverState m r s f act ps i o)
-> m ()
forall a b. (a -> b) -> a -> b
$ \DriverState m r s f act ps i o
st ->
      DriverState m r s f act ps i o
st {refs = M.alter (const el) p st.refs}
  Input.Action act
act -> do
    st <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
    evalM render ref (runNT st.component.eval (HQ.Action act ()))

{-# SPECIALIZE evalQ :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> f a -> IO (Maybe a) #-}
evalQ
  :: (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)
  => Renderer m r
  -> IORef (DriverState m r s f act ps i o)
  -> f a
  -> m (Maybe a)
evalQ :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o a.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o) -> f a -> m (Maybe a)
evalQ Renderer m r
render IORef (DriverState m r s f act ps i o)
ref f a
q = do
  st <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
  evalM render ref (runNT st.component.eval (HQ.Query (Just <$> liftCoyoneda q) (const Nothing)))

{-# SPECIALIZE evalM :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> HalogenM s act ps o IO a -> IO a #-}
evalM
  :: forall m r s f act ps i o a
   . (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)
  => Renderer m r
  -> IORef (DriverState m r s f act ps i o)
  -> HalogenM s act ps o m a
  -> m a
evalM :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o a.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o)
-> HalogenM s act ps o m a
-> m a
evalM Renderer m r
render IORef (DriverState m r s f act ps i o)
initRef (HalogenM F (HalogenF s act ps o m) a
hm) = (forall x. HalogenF s act ps o m x -> m x)
-> F (HalogenF s act ps o m) a -> m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> F f a -> m a
foldF (IORef (DriverState m r s f act ps i o)
-> HalogenF s act ps o m x -> m x
forall x.
IORef (DriverState m r s f act ps i o)
-> HalogenF s act ps o m x -> m x
go IORef (DriverState m r s f act ps i o)
initRef) F (HalogenF s act ps o m) a
hm
  where
    go
      :: forall x
       . IORef (DriverState m r s f act ps i o)
      -> HalogenF s act ps o m x
      -> m x
    go :: forall x.
IORef (DriverState m r s f act ps i o)
-> HalogenF s act ps o m x -> m x
go IORef (DriverState m r s f act ps i o)
ref = \case
      State s -> (x, s)
f -> do
        st@DriverState {state, lifecycleHandlers} <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
        case f state of
          (x
a, s
state')
            | s -> s -> Bool
forall a. a -> a -> Bool
unsafeRefEq s
state s
state' -> x -> m x
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a
            | Bool
otherwise -> do
                IORef (DriverState m r s f act ps i o)
-> DriverState m r s f act ps i o -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (DriverState m r s f act ps i o)
ref (DriverState m r s f act ps i o
st {state = state'})
                IORef (LifecycleHandlers m) -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadParallel m, MonadFork m) =>
IORef (LifecycleHandlers m) -> m a -> m a
handleLifecycle IORef (LifecycleHandlers m)
lifecycleHandlers (IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render IORef (LifecycleHandlers m)
lifecycleHandlers IORef (DriverState m r s f act ps i o)
ref)
                x -> m x
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a
      Subscribe SubscriptionId -> Emitter IO act
fes SubscriptionId -> x
k -> do
        sid <- (Int -> SubscriptionId)
-> IORef (DriverState m r s f act ps i o) -> m SubscriptionId
forall (m :: * -> *) a (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
MonadIO m =>
(Int -> a) -> IORef (DriverState m r s f act ps i o) -> m a
fresh Int -> SubscriptionId
SubscriptionId IORef (DriverState m r s f act ps i o)
ref
        finalize <- fmap (HS.hoistSubscription (NT liftIO)) $ withRunInIO $ \forall a. m a -> IO a
runInIO -> Emitter IO act -> (act -> IO ()) -> IO (Subscription IO)
forall (m :: * -> *) a r.
Functor m =>
Emitter m a -> (a -> m r) -> m (Subscription m)
HS.subscribe (SubscriptionId -> Emitter IO act
fes SubscriptionId
sid) ((act -> IO ()) -> IO (Subscription IO))
-> (act -> IO ()) -> IO (Subscription IO)
forall a b. (a -> b) -> a -> b
$ \act
act ->
          m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Renderer m r
-> IORef (DriverState m r s f act ps i o) -> Input act -> m ()
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o) -> Input act -> m ()
evalF IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render IORef (DriverState m r s f act ps i o)
ref (act -> Input act
forall msg. msg -> Input msg
Input.Action act
act)
        DriverState {subscriptions} <- readIORef ref
        atomicModifyIORef'_ subscriptions (map (M.insert sid finalize))
        pure (k sid)
      Unsubscribe SubscriptionId
sid x
next -> do
        SubscriptionId -> IORef (DriverState m r s f act ps i o) -> m ()
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s'
       (f' :: * -> *) act' (ps' :: Row (*)) i' o'.
MonadIO m =>
SubscriptionId
-> IORef (DriverState m r s' f' act' ps' i' o') -> m ()
unsubscribe SubscriptionId
sid IORef (DriverState m r s f act ps i o)
ref
        x -> m x
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
next
      Lift m x
aff ->
        m x
aff
      Unlift UnliftIO (HalogenM s act ps o m) -> IO x
q -> ((forall a. m a -> IO a) -> IO x) -> m x
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO x) -> m x)
-> ((forall a. m a -> IO a) -> IO x) -> m x
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> UnliftIO (HalogenM s act ps o m) -> IO x
q ((forall a. HalogenM s act ps o m a -> IO a)
-> UnliftIO (HalogenM s act ps o m)
forall (m :: * -> *). (forall a. m a -> IO a) -> UnliftIO m
UnliftIO ((forall a. HalogenM s act ps o m a -> IO a)
 -> UnliftIO (HalogenM s act ps o m))
-> (forall a. HalogenM s act ps o m a -> IO a)
-> UnliftIO (HalogenM s act ps o m)
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a)
-> (HalogenM s act ps o m a -> m a)
-> HalogenM s act ps o m a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renderer m r
-> IORef (DriverState m r s f act ps i o)
-> HalogenM s act ps o m a
-> m a
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o a.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o)
-> HalogenM s act ps o m a
-> m a
evalM IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render IORef (DriverState m r s f act ps i o)
initRef)
      ChildQuery ChildQuery ps x
cq ->
        IORef (DriverState m r s f act ps i o) -> ChildQuery ps x -> m x
forall x.
IORef (DriverState m r s f act ps i o) -> ChildQuery ps x -> m x
evalChildQuery IORef (DriverState m r s f act ps i o)
ref ChildQuery ps x
cq
      Raise o
o x
a -> do
        DriverState {handlerRef, pendingOuts} <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
        handler <- readIORef handlerRef
        queueOrRun pendingOuts (handler o)
        pure a
      Par (HalogenAp Ap (HalogenM s act ps o m) x
p) -> Parallel m x -> m x
forall a. Parallel m a -> m a
forall (m :: * -> *) a. MonadParallel m => Parallel m a -> m a
sequential (Parallel m x -> m x) -> Parallel m x -> m x
forall a b. (a -> b) -> a -> b
$ Ap (Parallel m) x -> Parallel m x
forall (f :: * -> *) a. Applicative f => Ap f a -> f a
retractAp (Ap (Parallel m) x -> Parallel m x)
-> Ap (Parallel m) x -> Parallel m x
forall a b. (a -> b) -> a -> b
$ (forall x. HalogenM s act ps o m x -> Parallel m x)
-> Ap (HalogenM s act ps o m) x -> Ap (Parallel m) x
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ap f a -> Ap g a
hoistAp (m x -> Parallel m x
forall a. m a -> Parallel m a
forall (m :: * -> *) a. MonadParallel m => m a -> Parallel m a
parallel (m x -> Parallel m x)
-> (HalogenM s act ps o m x -> m x)
-> HalogenM s act ps o m x
-> Parallel m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renderer m r
-> IORef (DriverState m r s f act ps i o)
-> HalogenM s act ps o m x
-> m x
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o a.
(MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m,
 MonadKill m) =>
Renderer m r
-> IORef (DriverState m r s f act ps i o)
-> HalogenM s act ps o m a
-> m a
evalM IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render IORef (DriverState m r s f act ps i o)
ref) Ap (HalogenM s act ps o m) x
p
      Fork HalogenM s act ps o m ()
hmu ForkId -> x
k -> do
        fid <- (Int -> ForkId)
-> IORef (DriverState m r s f act ps i o) -> m ForkId
forall (m :: * -> *) a (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
MonadIO m =>
(Int -> a) -> IORef (DriverState m r s f act ps i o) -> m a
fresh Int -> ForkId
ForkId IORef (DriverState m r s f act ps i o)
ref
        DriverState {forks} <- readIORef ref
        doneRef <- newIORef False
        fiber <-
          fork
            $ finally
              ( do
                  atomicModifyIORef'_ forks (M.delete fid)
                  atomicWriteIORef doneRef True
              )
              (evalM render ref hmu)
        unlessM (readIORef doneRef) $ do
          atomicModifyIORef'_ forks (M.insert fid fiber)
        pure (k fid)
      Join ForkId
fid x
a -> do
        DriverState {forks} <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
        forkMap <- readIORef forks
        traverse_ join (M.lookup fid forkMap)
        pure a
      Kill ForkId
fid x
a -> do
        DriverState {forks} <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
        forkMap <- readIORef forks
        traverse_ (kill AsyncCancelled) (M.lookup fid forkMap)
        pure a
      GetRef (Input.RefLabel Text
p) Maybe Element -> x
k -> do
        DriverState {refs} <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
        pure $ k $ M.lookup p refs

    evalChildQuery
      :: IORef (DriverState m r s f act ps i o)
      -> CQ.ChildQuery ps x
      -> m x
    evalChildQuery :: forall x.
IORef (DriverState m r s f act ps i o) -> ChildQuery ps x -> m x
evalChildQuery IORef (DriverState m r s f act ps i o)
ref (CQ.ChildQuery forall (slot :: (* -> *) -> * -> *) (m :: * -> *).
Applicative m =>
(slot g o -> m (Maybe b)) -> SlotStorage ps slot -> m (f b)
unpack g b
query f b -> x
reply) = do
      st <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
      let evalChild (DriverStateRef IORef (DriverState m r s g act ps i o)
var) = m (Maybe b) -> Parallel m (Maybe b)
forall a. m a -> Parallel m a
forall (m :: * -> *) a. MonadParallel m => m a -> Parallel m a
parallel (m (Maybe b) -> Parallel m (Maybe b))
-> m (Maybe b) -> Parallel m (Maybe b)
forall a b. (a -> b) -> a -> b
$ do
            dsx <- IORef (DriverState m r s g act ps i o)
-> m (DriverState m r s g act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s g act ps i o)
var
            evalQ render dsx.selfRef query
      reply <$> sequential (unpack evalChild st.children)

{-# SPECIALIZE unsubscribe :: SubscriptionId -> IORef (DriverState IO r s f act ps i o) -> IO () #-}
unsubscribe
  :: (MonadIO m)
  => SubscriptionId
  -> IORef (DriverState m r s' f' act' ps' i' o')
  -> m ()
unsubscribe :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s'
       (f' :: * -> *) act' (ps' :: Row (*)) i' o'.
MonadIO m =>
SubscriptionId
-> IORef (DriverState m r s' f' act' ps' i' o') -> m ()
unsubscribe SubscriptionId
sid IORef (DriverState m r s' f' act' ps' i' o')
ref = do
  DriverState {subscriptions} <- IORef (DriverState m r s' f' act' ps' i' o')
-> m (DriverState m r s' f' act' ps' i' o')
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s' f' act' ps' i' o')
ref
  subs <- readIORef subscriptions
  traverse_ HS.unsubscribe (M.lookup sid =<< subs)

{-# SPECIALIZE handleLifecycle :: IORef (LifecycleHandlers IO) -> IO a -> IO a #-}
handleLifecycle :: (MonadIO m, MonadParallel m, MonadFork m) => IORef (LifecycleHandlers m) -> m a -> m a
handleLifecycle :: forall (m :: * -> *) a.
(MonadIO m, MonadParallel m, MonadFork m) =>
IORef (LifecycleHandlers m) -> m a -> m a
handleLifecycle IORef (LifecycleHandlers m)
lchs m a
f = do
  IORef (LifecycleHandlers m) -> LifecycleHandlers m -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (LifecycleHandlers m)
lchs (LifecycleHandlers m -> m ()) -> LifecycleHandlers m -> m ()
forall a b. (a -> b) -> a -> b
$ LifecycleHandlers {initializers :: [m ()]
initializers = [], finalizers :: [m ()]
finalizers = []}
  result <- m a
f
  LifecycleHandlers {initializers, finalizers} <- readIORef lchs
  traverse_ fork finalizers
  parSequence_ initializers
  pure result

{-# SPECIALIZE fresh :: (Int -> a) -> IORef (DriverState IO r s f act ps i o) -> IO a #-}
fresh
  :: (MonadIO m)
  => (Int -> a)
  -> IORef (DriverState m r s f act ps i o)
  -> m a
fresh :: forall (m :: * -> *) a (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
MonadIO m =>
(Int -> a) -> IORef (DriverState m r s f act ps i o) -> m a
fresh Int -> a
f IORef (DriverState m r s f act ps i o)
ref = do
  st <- IORef (DriverState m r s f act ps i o)
-> m (DriverState m r s f act ps i o)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s f act ps i o)
ref
  atomicModifyIORef' st.fresh (\Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> a
f Int
i))

{-# SPECIALIZE queueOrRun :: IORef (Maybe [IO ()]) -> IO () -> IO () #-}
queueOrRun
  :: (MonadIO m)
  => IORef (Maybe [m ()])
  -> m ()
  -> m ()
queueOrRun :: forall (m :: * -> *).
MonadIO m =>
IORef (Maybe [m ()]) -> m () -> m ()
queueOrRun IORef (Maybe [m ()])
ref m ()
au =
  IORef (Maybe [m ()]) -> m (Maybe [m ()])
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe [m ()])
ref m (Maybe [m ()]) -> (Maybe [m ()] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe [m ()]
Nothing -> m ()
au
    Just [m ()]
p -> IORef (Maybe [m ()]) -> Maybe [m ()] -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (Maybe [m ()])
ref ([m ()] -> Maybe [m ()]
forall a. a -> Maybe a
Just (m ()
au m () -> [m ()] -> [m ()]
forall a. a -> [a] -> [a]
: [m ()]
p))