@@ -108,6 +108,7 @@ import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
108108import Reflex.TriggerEvent.Class
109109
110110import Control.Concurrent
111+import Control.Exception (bracketOnError)
111112import Control.Lens hiding (element, ix)
112113import Control.Monad.Exception
113114import Control.Monad.Primitive
@@ -500,16 +501,15 @@ collectUpToGivenParent currentParent s e = do
500501 extractUpTo df s e
501502 return df
502503
504+-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
503505{-# INLINABLE wrap #-}
504506wrap
505507 :: forall m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)
506508 => Chan [DSum (EventTriggerRef t) TriggerInvocation]
507509 -> RawElement GhcjsDomSpace
508510 -> RawElementConfig er t HydrationDomSpace
509−-- -> m (Event t (DMap (WrapArg er EventName) Identity))
510− -> m (EventSelector t (WrapArg er EventName))
511+ -> m (DMap EventName (EventFilterTriggerRef t er))
511512wrap events e cfg = do
512− liftIO $ putStrLn $ "called wrap"
513513 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
514514 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
515515 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
@@ -526,28 +526,7 @@ wrap events e cfg = do
526526 mv <- liftJSM k --TODO: Only do this when the event is subscribed
527527 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
528528 return $ en :=> EventFilterTriggerRef triggerRef
529− es <- do
530− let h :: GhcjsEventHandler er
531− !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
532− ctx <- askJSM
533−
534− newFanEventWithTrigger $ \(WrapArg en) t ->
535− case DMap.lookup en eventTriggerRefs of
536− Just (EventFilterTriggerRef r) -> do
537− writeIORef r $ Just t
538− return $ do
539− writeIORef r Nothing
540− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
541− evt <- DOM.event
542− mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
543− case mv of
544− Nothing -> return ()
545− Just v -> liftIO $ do
546− --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
547− ref <- newIORef $ Just t
548− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
549−
550− return es
529+ return eventTriggerRefs
551530
552531{-# INLINABLE makeElement #-}
553532makeElement
@@ -558,6 +537,9 @@ makeElement
558537 -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)
559538makeElement elementTag cfg child = do
560539 doc <- askDocument
540+ ctx <- askJSM
541+ events <- askEvents
542+
561543 let buildElement :: HydrationDomBuilderT' env state t m DOM.Element
562544 buildElement = do
563545 e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
@@ -572,6 +554,25 @@ makeElement elementTag cfg child = do
572554 hasSSRAttribute e = case cfg ^. namespace of
573555 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr
574556 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr
557+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
558+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
559+ handler :: GhcjsEventHandler er
560+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
561+ triggerBody :: DMap EventName (EventFilterTriggerRef t er) -> DOM.Element -> WrapArg er EventName x -> EventTrigger t x -> IO (IO ())
562+ triggerBody eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
563+ Just (EventFilterTriggerRef r) -> do
564+ writeIORef r $ Just t
565+ return $ do
566+ writeIORef r Nothing
567+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
568+ evt <- DOM.event
569+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
570+ case mv of
571+ Nothing -> return ()
572+ Just v -> liftIO $ do
573+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
574+ ref <- newIORef $ Just t
575+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
575576 getHydrationMode >>= \case
576577 HydrationMode_Immediate -> do
577578 -- TODO: prerender needs completely replacing
@@ -580,26 +581,48 @@ makeElement elementTag cfg child = do
580581 -- Run the child builder with updated parent and previous sibling references
581582 result <- localEnv (\hs -> hs) (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
582583 events <- askEvents
583− es <- wrap events e $ extractRawElementConfig cfg
584+ eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg
585+ es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e
584586 return ((Element es (), result), e)
585587 HydrationMode_Hydrating -> do
586588 -- Schedule everything for after postBuild, except for getting the result itself
587− p <- liftIO $ newIORef $ error "Parent not yet initialized"
589+ parent <- liftIO $ newIORef $ error "Parent not yet initialized"
588590 env <- HydrationDomBuilderT ask
589− let env' = env { _hydrationDomBuilderEnv_parent = p}
591+ let env' = env { _hydrationDomBuilderEnv_parent = parent}
590592 hs = HydrationDomBuilderState { _hydrationDomBuilderState_delayed = [] }
591593 (result, hs') <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') hs
592− (ese, fire) <- newTriggerEvent
594+ wrapResult <- liftIO newEmptyMVar
593595 let activateElement = do
594596 e <- hydrateNode hasSSRAttribute buildElement DOM.Element
595− liftIO $ writeIORef p $ toNode e
596− events <- askEvents
597− void $ liftIO . fire <=< wrap events e $ extractRawElementConfig cfg
597+ -- Update the parent node used by the children
598+ liftIO $ writeIORef parent $ toNode e
599+ -- Setup events, store the result so we can wait on it later
600+ refs <- wrap events e $ extractRawElementConfig cfg
601+ liftIO $ putMVar wrapResult (e, refs)
598602 pure $ toNode e
599603 addAction $ DOM_Element activateElement $ _hydrationDomBuilderState_delayed hs'
600− -- TODO! vvv this can't stay here, obviously.
601− collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click))
602− return ((Element (fan collapsed) (), result), error "makeElement: DOM.Element")
604+
605+ -- We need the EventSelector to switch to the real event handler after activation
606+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
607+ cleanup <- newEmptyMVar
608+ threadId <- forkIO $ do
609+ -- Wait on the data we need from the delayed action
610+ (e, eventTriggerRefs) <- readMVar wrapResult
611+ bracketOnError
612+ -- Run the setup, acquiring the cleanup action
613+ (triggerBody eventTriggerRefs e (WrapArg en) t)
614+ -- Run the cleanup, if we have it - but only when an exception is
615+ -- raised (we might get killed between acquiring the cleanup action
616+ -- from 'triggerBody' and putting it in the MVar)
617+ (\m -> m)
618+ -- Try to put this action into the cleanup MVar
619+ (\m -> putMVar cleanup m)
620+ pure $ do
621+ tryReadMVar cleanup >>= \case
622+ Nothing -> killThread threadId
623+ Just c -> c
624+
625+ return ((Element es (), result), error "makeElement: DOM.Element")
603626
604627{-# INLINABLE textNodeInternal #-}
605628textNodeInternal :: (MonadJSM m, MonadFix m, ToDOMString contents, Reflex t) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Text