module Halogen.IO.Driver
  ( RenderSpec (..)
  , runUI
  , HalogenSocket (..)
  )
where

import Control.Exception.Safe
import Control.Monad.Fork
import Control.Monad.Parallel
import Control.Monad.UUID
import Data.NT
import Data.Row
import HPrelude hiding (get)
import Halogen.Component
import Halogen.Data.Slot qualified as Slot
import Halogen.HTML.Core qualified as HC
import Halogen.IO.Driver.Eval qualified as Eval
import Halogen.IO.Driver.State
import Halogen.Query.HalogenQ qualified as HQ
import Halogen.Query.Input
import Halogen.Query.Input qualified as Input
import Halogen.Subscription qualified as HS
import Unsafe.Coerce (unsafeCoerce)

data HalogenSocket query output m = HalogenSocket
  { forall (query :: * -> *) output (m :: * -> *).
HalogenSocket query output m -> forall a. query a -> m (Maybe a)
query :: forall a. query a -> m (Maybe a)
  , forall (query :: * -> *) output (m :: * -> *).
HalogenSocket query output m -> Emitter m output
messages :: HS.Emitter m output
  , forall (query :: * -> *) output (m :: * -> *).
HalogenSocket query output m -> m ()
dispose :: m ()
  }

data RenderSpec (m :: Type -> Type) (r :: Type -> Type -> Row Type -> Type -> Type) = RenderSpec
  { forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o.
   (Input act -> m ())
   -> (ComponentSlotBox ps m act -> m (RenderStateX r))
   -> HTML (ComponentSlot ps m act) act
   -> Maybe (r s act ps o)
   -> m (r s act ps o)
render
      :: forall s act ps o
       . (Input act -> m ())
      -> (ComponentSlotBox ps m act -> m (RenderStateX r))
      -> HC.HTML (ComponentSlot ps m act) act
      -> Maybe (r s act ps o)
      -> m (r s act ps o)
  , forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> r s act ps o
renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> m ()
removeChild :: forall s act ps o. r s act ps o -> m ()
  , forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> m ()
dispose :: forall s act ps o. r s act ps o -> m ()
  }

{-# SPECIALIZE runUI :: RenderSpec IO r -> Component f i o IO -> i -> IO (HalogenSocket f o IO) #-}
runUI
  :: forall m r f i o
   . (MonadUnliftIO m, MonadFork m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)
  => RenderSpec m r
  -> Component f i o m
  -> i
  -> m (HalogenSocket f o m)
runUI :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *)
       (f :: * -> *) i o.
(MonadUnliftIO m, MonadFork m, MonadKill m, MonadParallel m,
 MonadMask m, MonadUUID m) =>
RenderSpec m r -> Component f i o m -> i -> m (HalogenSocket f o m)
runUI RenderSpec {forall s act (ps :: Row (*)) o. r s act ps o -> m ()
forall s act (ps :: Row (*)) o. r s act ps o -> r s act ps o
forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX r))
-> HTML (ComponentSlot ps m act) act
-> Maybe (r s act ps o)
-> m (r s act ps o)
render :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o.
   (Input act -> m ())
   -> (ComponentSlotBox ps m act -> m (RenderStateX r))
   -> HTML (ComponentSlot ps m act) act
   -> Maybe (r s act ps o)
   -> m (r s act ps o)
renderChild :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> r s act ps o
removeChild :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> m ()
dispose :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *).
RenderSpec m r
-> forall s act (ps :: Row (*)) o. r s act ps o -> m ()
render :: forall s act (ps :: Row (*)) o.
(Input act -> m ())
-> (ComponentSlotBox ps m act -> m (RenderStateX r))
-> HTML (ComponentSlot ps m act) act
-> Maybe (r s act ps o)
-> m (r s act ps o)
renderChild :: forall s act (ps :: Row (*)) o. r s act ps o -> r s act ps o
removeChild :: forall s act (ps :: Row (*)) o. r s act ps o -> m ()
dispose :: forall s act (ps :: Row (*)) o. r s act ps o -> m ()
..} Component f i o m
c i
i = do
  lchs <- m (IORef (LifecycleHandlers m))
forall (m :: * -> *). MonadIO m => m (IORef (LifecycleHandlers m))
newLifecycleHandlers
  disposed <- newIORef False
  Eval.handleLifecycle lchs $ do
    sio <- HS.create
    dsx@(DriverStateX st) <- readDriverStateRef =<< runComponent lchs (HS.notify sio.listener) i c
    pure
      $ HalogenSocket
        { query = evalDriver disposed st.selfRef
        , messages = sio.emitter
        , dispose = dispose' disposed lchs dsx
        }
  where
    evalDriver
      :: forall s f' act ps i' o'
       . IORef Bool
      -> IORef (DriverState m r s f' act ps i' o')
      -> (forall a. f' a -> m (Maybe a))
    evalDriver :: forall s (f' :: * -> *) act (ps :: Row (*)) i' o'.
IORef Bool
-> IORef (DriverState m r s f' act ps i' o')
-> forall a. f' a -> m (Maybe a)
evalDriver IORef Bool
disposed IORef (DriverState m r s f' act ps i' o')
ref f' a
q =
      IORef Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
disposed m Bool -> (Bool -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Bool
False -> Renderer m r
-> IORef (DriverState m r s f' act ps i' o') -> f' a -> m (Maybe 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) -> f a -> m (Maybe a)
Eval.evalQ 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 f' a
q

    runComponent
      :: forall f' i' o'
       . IORef (LifecycleHandlers m)
      -> (o' -> m ())
      -> i'
      -> Component f' i' o' m
      -> m (DriverStateRef m r f' o')
    runComponent :: forall (f' :: * -> *) i' o'.
IORef (LifecycleHandlers m)
-> (o' -> m ())
-> i'
-> Component f' i' o' m
-> m (DriverStateRef m r f' o')
runComponent IORef (LifecycleHandlers m)
lchs o' -> m ()
handler i'
j (Component ComponentSpec model f' msg slots i' o' m
cs) = do
      lchs' <- m (IORef (LifecycleHandlers m))
forall (m :: * -> *). MonadIO m => m (IORef (LifecycleHandlers m))
newLifecycleHandlers
      st <- initDriverState cs j handler lchs'
      pre <- readIORef lchs
      atomicWriteIORef lchs $ LifecycleHandlers {initializers = [], finalizers = pre.finalizers}
      render' lchs st.selfRef
      squashChildInitializers lchs pre.initializers (DriverStateX st)
      pure $ DriverStateRef st.selfRef

    render'
      :: forall s f' act ps i' o'
       . IORef (LifecycleHandlers m)
      -> IORef (DriverState m r s f' act ps i' o')
      -> m ()
    render' :: Renderer m r
render' IORef (LifecycleHandlers m)
lchs IORef (DriverState m r s f' act ps i' o')
var =
      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')
var m (DriverState m r s f' act ps i' o')
-> (DriverState m r s f' act ps i' o' -> 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
>>= \DriverState m r s f' act ps i' o'
ds -> do
        shouldProcessHandlers <- Maybe [m ()] -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe [m ()] -> Bool) -> m (Maybe [m ()]) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe [m ()]) -> m (Maybe [m ()])
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef DriverState m r s f' act ps i' o'
ds.pendingHandlers
        when shouldProcessHandlers $ atomicWriteIORef ds.pendingHandlers (Just [])
        atomicWriteIORef ds.childrenOut Slot.empty
        atomicWriteIORef ds.childrenIn ds.children

        let -- The following 3 defs are working around a capture bug, see #586
            -- pendingHandlers = identity ds.pendingHandlers
            -- pendingQueries = identity ds.pendingQueries
            -- selfRef = identity ds.selfRef

            handler :: Input act -> m ()
            handler = IORef (Maybe [m ()]) -> m () -> m ()
forall (m :: * -> *).
MonadIO m =>
IORef (Maybe [m ()]) -> m () -> m ()
Eval.queueOrRun DriverState m r s f' act ps i' o'
ds.pendingHandlers (m () -> m ()) -> (Input act -> m ()) -> Input act -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (Input act -> m ()) -> Input act -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ()
Eval.evalF IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render' DriverState m r s f' act ps i' o'
ds.selfRef

            childHandler :: act -> m ()
            childHandler = IORef (Maybe [m ()]) -> m () -> m ()
forall (m :: * -> *).
MonadIO m =>
IORef (Maybe [m ()]) -> m () -> m ()
Eval.queueOrRun DriverState m r s f' act ps i' o'
ds.pendingQueries (m () -> m ()) -> (act -> m ()) -> act -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input act -> m ()
handler (Input act -> m ()) -> (act -> Input act) -> act -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. act -> Input act
forall msg. msg -> Input msg
Input.Action

        rendering <-
          render
            handler
            (renderChild' lchs childHandler ds.childrenIn ds.childrenOut)
            (ds.component.render ds.state)
            ds.rendering

        children <- readIORef ds.childrenOut
        childrenIn <- readIORef ds.childrenIn

        Slot.foreachSlot childrenIn $ \(DriverStateRef IORef (DriverState m r s query act ps i output)
childVar) -> do
          childDS <- DriverState m r s query act ps i output
-> DriverStateX m r query output
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *)
       (f :: * -> *) o s act (ps :: Row (*)) i.
DriverState m r s f act ps i o -> DriverStateX m r f o
DriverStateX (DriverState m r s query act ps i output
 -> DriverStateX m r query output)
-> m (DriverState m r s query act ps i output)
-> m (DriverStateX m r query output)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (DriverState m r s query act ps i output)
-> m (DriverState m r s query act ps i output)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s query act ps i output)
childVar
          renderStateX_ removeChild childDS
          finalize lchs childDS

        atomicModifyIORef'_ ds.selfRef $ \DriverState m r s f' act ps i' o'
ds' ->
          DriverState m r s f' act ps i' o'
ds' {rendering = Just rendering, children = children}

        when shouldProcessHandlers $ do
          flip loopM () $ \()
_ -> do
            handlers <- IORef (Maybe [m ()]) -> m (Maybe [m ()])
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef DriverState m r s f' act ps i' o'
ds.pendingHandlers
            atomicWriteIORef ds.pendingHandlers (Just [])
            traverse_ (traverse_ fork . reverse) handlers
            mmore <- readIORef ds.pendingHandlers
            if maybe False null mmore
              then atomicWriteIORef ds.pendingHandlers Nothing $> Right ()
              else pure $ Left ()

    renderChild'
      :: forall ps act
       . IORef (LifecycleHandlers m)
      -> (act -> m ())
      -> IORef (Slot.SlotStorage ps (DriverStateRef m r))
      -> IORef (Slot.SlotStorage ps (DriverStateRef m r))
      -> ComponentSlotBox ps m act
      -> m (RenderStateX r)
    renderChild' :: forall (ps :: Row (*)) act.
IORef (LifecycleHandlers m)
-> (act -> m ())
-> IORef (SlotStorage ps (DriverStateRef m r))
-> IORef (SlotStorage ps (DriverStateRef m r))
-> ComponentSlotBox ps m act
-> m (RenderStateX r)
renderChild' IORef (LifecycleHandlers m)
lchs act -> m ()
handler IORef (SlotStorage ps (DriverStateRef m r))
childrenInRef IORef (SlotStorage ps (DriverStateRef m r))
childrenOutRef ComponentSlotBox {input
Component query input output m
output -> Maybe act
forall (slot :: (* -> *) -> * -> *).
slot query output -> SlotStorage ps slot -> SlotStorage ps slot
forall (slot :: (* -> *) -> * -> *).
SlotStorage ps slot -> Maybe (slot query output)
forall (slot :: (* -> *) -> * -> *).
SlotStorage ps slot
-> Maybe (slot query output, SlotStorage ps slot)
get :: forall (slot :: (* -> *) -> * -> *).
SlotStorage ps slot -> Maybe (slot query output)
pop :: forall (slot :: (* -> *) -> * -> *).
SlotStorage ps slot
-> Maybe (slot query output, SlotStorage ps slot)
set :: forall (slot :: (* -> *) -> * -> *).
slot query output -> SlotStorage ps slot -> SlotStorage ps slot
component :: Component query input output m
input :: input
output :: output -> Maybe act
component :: ()
get :: ()
input :: ()
output :: ()
pop :: ()
set :: ()
..} = do
      childrenIn <- SlotStorage ps (DriverStateRef m r)
-> Maybe
     (DriverStateRef m r query output,
      SlotStorage ps (DriverStateRef m r))
forall (slot :: (* -> *) -> * -> *).
SlotStorage ps slot
-> Maybe (slot query output, SlotStorage ps slot)
pop (SlotStorage ps (DriverStateRef m r)
 -> Maybe
      (DriverStateRef m r query output,
       SlotStorage ps (DriverStateRef m r)))
-> m (SlotStorage ps (DriverStateRef m r))
-> m (Maybe
        (DriverStateRef m r query output,
         SlotStorage ps (DriverStateRef m r)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (SlotStorage ps (DriverStateRef m r))
-> m (SlotStorage ps (DriverStateRef m r))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (SlotStorage ps (DriverStateRef m r))
childrenInRef
      var <- case childrenIn of
        Just (DriverStateRef m r query output
existing, SlotStorage ps (DriverStateRef m r)
childrenIn') -> do
          IORef (SlotStorage ps (DriverStateRef m r))
-> SlotStorage ps (DriverStateRef m r) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (SlotStorage ps (DriverStateRef m r))
childrenInRef SlotStorage ps (DriverStateRef m r)
childrenIn'
          DriverStateX st <- DriverStateRef m r query output
-> m (DriverStateX m r query output)
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *)
       (f :: * -> *) o.
MonadIO m =>
DriverStateRef m r f o -> m (DriverStateX m r f o)
readDriverStateRef DriverStateRef m r query output
existing
          atomicWriteIORef st.handlerRef $ maybe pass handler . output
          -- FIXME
          void $ Eval.evalM render' st.selfRef (runNT (unsafeCoerce st.component.eval) (HQ.Receive input ()))
          pure existing
        Maybe
  (DriverStateRef m r query output,
   SlotStorage ps (DriverStateRef m r))
Nothing ->
          IORef (LifecycleHandlers m)
-> (output -> m ())
-> input
-> Component query input output m
-> m (DriverStateRef m r query output)
forall (f' :: * -> *) i' o'.
IORef (LifecycleHandlers m)
-> (o' -> m ())
-> i'
-> Component f' i' o' m
-> m (DriverStateRef m r f' o')
runComponent IORef (LifecycleHandlers m)
lchs (m () -> (act -> m ()) -> Maybe act -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
forall (f :: * -> *). Applicative f => f ()
pass act -> m ()
handler (Maybe act -> m ()) -> (output -> Maybe act) -> output -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. output -> Maybe act
output) input
input Component query input output m
component
      isDuplicate <- isJust . get <$> readIORef childrenOutRef
      when isDuplicate
        $ traceM "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      atomicModifyIORef'_ childrenOutRef (set var)
      (readDriverStateRef var >>=) $ renderStateX $ \case
        Maybe (r s act ps output)
Nothing -> String -> m (r s act ps output)
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
"Halogen internal error: child was not initialized in renderChild"
        Just r s act ps output
r -> r s act ps output -> m (r s act ps output)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r s act ps output -> r s act ps output
forall s act (ps :: Row (*)) o. r s act ps o -> r s act ps o
renderChild r s act ps output
r)

    squashChildInitializers
      :: forall f' o'
       . IORef (LifecycleHandlers m)
      -> [m ()]
      -> DriverStateX m r f' o'
      -> m ()
    squashChildInitializers :: forall (f' :: * -> *) o'.
IORef (LifecycleHandlers m)
-> [m ()] -> DriverStateX m r f' o' -> m ()
squashChildInitializers IORef (LifecycleHandlers m)
lchs [m ()]
preInits (DriverStateX DriverState m r s f' act ps i o'
st) = do
      let parentInitializer :: m ()
parentInitializer = Renderer m r
-> IORef (DriverState m r s f' act ps i o')
-> HalogenM s act ps o' m ()
-> m ()
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
Eval.evalM IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render' DriverState m r s f' act ps i o'
st.selfRef ((HalogenQ f' act i ~> HalogenM s act ps o' m)
-> HalogenQ f' act i () -> HalogenM s act ps o' m ()
forall {k} (m :: k -> *) (n :: k -> *) (a :: k).
(m ~> n) -> m a -> n a
runNT DriverState m r s f' act ps i o'
st.component.eval (() -> HalogenQ f' act i ()
forall (query :: * -> *) msg input a.
a -> HalogenQ query msg input a
HQ.Initialize ()))
      IORef (LifecycleHandlers m)
-> (LifecycleHandlers m -> LifecycleHandlers m) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
atomicModifyIORef'_ IORef (LifecycleHandlers m)
lchs ((LifecycleHandlers m -> LifecycleHandlers m) -> m ())
-> (LifecycleHandlers m -> LifecycleHandlers m) -> m ()
forall a b. (a -> b) -> a -> b
$ \LifecycleHandlers m
handlers ->
        LifecycleHandlers m
handlers
          { initializers =
              ( do
                  parSequence_ (reverse handlers.initializers)
                  parentInitializer
                  handlePending st.pendingQueries
                  handlePending st.pendingOuts
              )
                : preInits
          , finalizers = handlers.finalizers
          }

    finalize
      :: forall f' o'
       . IORef (LifecycleHandlers m)
      -> DriverStateX m r f' o'
      -> m ()
    finalize :: forall (f' :: * -> *) o'.
IORef (LifecycleHandlers m) -> DriverStateX m r f' o' -> m ()
finalize IORef (LifecycleHandlers m)
lchs (DriverStateX DriverState {IORef (DriverState m r s f' act ps i o')
selfRef :: IORef (DriverState m r s f' act ps i o')
selfRef :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
DriverState m r s f act ps i o
-> IORef (DriverState m r s f act ps i o)
selfRef}) = 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')
selfRef
      cleanupSubscriptionsAndForks st
      let f = Renderer m r
-> IORef (DriverState m r s f' act ps i o')
-> HalogenM s act ps o' m ()
-> m ()
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
Eval.evalM IORef (LifecycleHandlers m)
-> IORef (DriverState m r s f act ps i o) -> m ()
Renderer m r
render' DriverState m r s f' act ps i o'
st.selfRef ((HalogenQ f' act i ~> HalogenM s act ps o' m)
-> HalogenQ f' act i () -> HalogenM s act ps o' m ()
forall {k} (m :: k -> *) (n :: k -> *) (a :: k).
(m ~> n) -> m a -> n a
runNT DriverState m r s f' act ps i o'
st.component.eval (() -> HalogenQ f' act i ()
forall (query :: * -> *) msg input a.
a -> HalogenQ query msg input a
HQ.Finalize ()))
      atomicModifyIORef'_ lchs $ \LifecycleHandlers m
handlers ->
        LifecycleHandlers m
handlers
          { initializers = handlers.initializers
          , finalizers = f : handlers.finalizers
          }
      Slot.foreachSlot st.children $ \(DriverStateRef IORef (DriverState m r s query act ps i output)
ref) -> do
        ds <- DriverState m r s query act ps i output
-> DriverStateX m r query output
forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *)
       (f :: * -> *) o s act (ps :: Row (*)) i.
DriverState m r s f act ps i o -> DriverStateX m r f o
DriverStateX (DriverState m r s query act ps i output
 -> DriverStateX m r query output)
-> m (DriverState m r s query act ps i output)
-> m (DriverStateX m r query output)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (DriverState m r s query act ps i output)
-> m (DriverState m r s query act ps i output)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (DriverState m r s query act ps i output)
ref
        finalize lchs ds

    dispose'
      :: forall f' o'
       . IORef Bool
      -> IORef (LifecycleHandlers m)
      -> DriverStateX m r f' o'
      -> m ()
    dispose' :: forall (f' :: * -> *) o'.
IORef Bool
-> IORef (LifecycleHandlers m) -> DriverStateX m r f' o' -> m ()
dispose' IORef Bool
disposed IORef (LifecycleHandlers m)
lchs dsx :: DriverStateX m r f' o'
dsx@(DriverStateX DriverState {IORef (DriverState m r s f' act ps i o')
selfRef :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
DriverState m r s f act ps i o
-> IORef (DriverState m r s f act ps i o)
selfRef :: IORef (DriverState m r s f' act ps i o')
selfRef}) = IORef (LifecycleHandlers m) -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadParallel m, MonadFork m) =>
IORef (LifecycleHandlers m) -> m a -> m a
Eval.handleLifecycle IORef (LifecycleHandlers m)
lchs (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      IORef Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
disposed m Bool -> (Bool -> 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
        Bool
True -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
        Bool
False -> do
          IORef Bool -> Bool -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef Bool
disposed Bool
True
          IORef (LifecycleHandlers m) -> DriverStateX m r f' o' -> m ()
forall (f' :: * -> *) o'.
IORef (LifecycleHandlers m) -> DriverStateX m r f' o' -> m ()
finalize IORef (LifecycleHandlers m)
lchs DriverStateX m r f' o'
dsx
          ds <- 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')
selfRef
          for_ ds.rendering dispose

{-# INLINE newLifecycleHandlers #-}
newLifecycleHandlers :: (MonadIO m) => m (IORef (LifecycleHandlers m))
newLifecycleHandlers :: forall (m :: * -> *). MonadIO m => m (IORef (LifecycleHandlers m))
newLifecycleHandlers = LifecycleHandlers m -> m (IORef (LifecycleHandlers m))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (LifecycleHandlers m -> m (IORef (LifecycleHandlers m)))
-> LifecycleHandlers m -> m (IORef (LifecycleHandlers m))
forall a b. (a -> b) -> a -> b
$ LifecycleHandlers {initializers :: [m ()]
initializers = [], finalizers :: [m ()]
finalizers = []}

{-# SPECIALIZE handlePending :: IORef (Maybe [IO ()]) -> IO () #-}
handlePending :: (MonadIO m, MonadFork m) => IORef (Maybe [m ()]) -> m ()
handlePending :: forall (m :: * -> *).
(MonadIO m, MonadFork m) =>
IORef (Maybe [m ()]) -> m ()
handlePending IORef (Maybe [m ()])
ref = do
  queue <- IORef (Maybe [m ()]) -> m (Maybe [m ()])
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe [m ()])
ref
  atomicWriteIORef ref Nothing
  for_ queue (traverse_ fork . reverse)

{-# SPECIALIZE cleanupSubscriptionsAndForks :: DriverState IO r s f act ps i o -> IO () #-}
cleanupSubscriptionsAndForks
  :: (MonadIO m, MonadKill m)
  => DriverState m r s f act ps i o
  -> m ()
cleanupSubscriptionsAndForks :: forall (m :: * -> *) (r :: * -> * -> Row (*) -> * -> *) s
       (f :: * -> *) act (ps :: Row (*)) i o.
(MonadIO m, MonadKill m) =>
DriverState m r s f act ps i o -> m ()
cleanupSubscriptionsAndForks DriverState m r s f act ps i o
ds = do
  (Map SubscriptionId (Subscription m) -> m ())
-> Maybe (Map SubscriptionId (Subscription m)) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Subscription m -> m ())
-> Map SubscriptionId (Subscription m) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Subscription m -> m ()
forall (m :: * -> *). Subscription m -> m ()
HS.unsubscribe) (Maybe (Map SubscriptionId (Subscription m)) -> m ())
-> m (Maybe (Map SubscriptionId (Subscription m))) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Maybe (Map SubscriptionId (Subscription m)))
-> m (Maybe (Map SubscriptionId (Subscription m)))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef DriverState m r s f act ps i o
ds.subscriptions
  IORef (Maybe (Map SubscriptionId (Subscription m)))
-> Maybe (Map SubscriptionId (Subscription m)) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef DriverState m r s f act ps i o
ds.subscriptions Maybe (Map SubscriptionId (Subscription m))
forall a. Maybe a
Nothing
  (Fork m () -> m ()) -> Map ForkId (Fork m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (AsyncCancelled -> Fork m () -> m ()
forall e a. Exception e => e -> Fork m a -> m ()
forall (m :: * -> *) e a.
(MonadKill m, Exception e) =>
e -> Fork m a -> m ()
kill AsyncCancelled
AsyncCancelled) (Map ForkId (Fork m ()) -> m ())
-> m (Map ForkId (Fork m ())) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map ForkId (Fork m ())) -> m (Map ForkId (Fork m ()))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef DriverState m r s f act ps i o
ds.forks
  IORef (Map ForkId (Fork m ())) -> Map ForkId (Fork m ()) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef DriverState m r s f act ps i o
ds.forks Map ForkId (Fork m ())
forall a. Monoid a => a
mempty