5427bc4 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

placeRawElement, wrapRawElement

5427bc4Tom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+43−23

compare with develop

unifiedsplit

@@ -59,6 +59,7 @@ import Control.Monad.Primitive

59import Control.Monad.Reader

60import Control.Monad.Ref

61import Control.Monad.State.Strict

62+import Data.Default

62import Data.Dependent.Map (DMap)

63import Data.Dependent.Map (DMap)

63import Data.Dependent.Sum

64import Data.Dependent.Sum

64import Data.FastMutableIntMap (PatchIntMap (..))

65import Data.FastMutableIntMap (PatchIntMap (..))

@@ -387,6 +388,35 @@ wrap events e cfg = do

387 return $ en :=> EventFilterTriggerRef triggerRef

388 return $ en :=> EventFilterTriggerRef triggerRef

388 return eventTriggerRefs

389 return eventTriggerRefs

389

390

391+triggerBody

392+ :: forall er t x. DOM.JSContextRef

393+ -> ElementConfig er t GhcjsDomSpace

394+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

395+ -> DMap EventName (EventFilterTriggerRef t er)

396+ -> DOM.Element

397+ -> WrapArg er EventName x

398+ -> EventTrigger t x

399+ -> IO (IO ())

400+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of

401+ Just (EventFilterTriggerRef r) -> do

402+ writeIORef r $ Just t

403+ return $ do

404+ writeIORef r Nothing

405+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

406+ evt <- DOM.event

407+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)

408+ case mv of

409+ Nothing -> return ()

410+ Just v -> liftIO $ do

411+ --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

412+ ref <- newIORef $ Just t

413+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

414+ where

415+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't

416+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

417+ handler :: GhcjsEventHandler er

418+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg

419+

390{-# INLINABLE makeElement #-}

420{-# INLINABLE makeElement #-}

391makeElement

421makeElement

392 :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)

422 :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)

@@ -413,25 +443,6 @@ makeElement elementTag cfg child = do

413 hasSSRAttribute e = case cfg ^. namespace of

443 hasSSRAttribute e = case cfg ^. namespace of

414 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr

444 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr

415 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr

445 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr

416− -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't

417− -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

418− handler :: GhcjsEventHandler er

419− !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg

420− triggerBody :: DMap EventName (EventFilterTriggerRef t er) -> DOM.Element -> WrapArg er EventName x -> EventTrigger t x -> IO (IO ())

421− triggerBody eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of

422− Just (EventFilterTriggerRef r) -> do

423− writeIORef r $ Just t

424− return $ do

425− writeIORef r Nothing

426− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

427− evt <- DOM.event

428− mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)

429− case mv of

430− Nothing -> return ()

431− Just v -> liftIO $ do

432− --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

433− ref <- newIORef $ Just t

434− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

435 getHydrationMode >>= \case

446 getHydrationMode >>= \case

436 HydrationMode_Immediate -> do

447 HydrationMode_Immediate -> do

437 e <- makeNodeInternal buildElement

448 e <- makeNodeInternal buildElement

@@ -439,7 +450,7 @@ makeElement elementTag cfg child = do

439 -- Run the child builder with updated parent and previous sibling references

450 -- Run the child builder with updated parent and previous sibling references

440 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child

451 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child

441 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg

452 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg

442− es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e

453+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e

443 e' <- liftIO $ newIORef e

454 e' <- liftIO $ newIORef e

444 return ((Element es e, result), e')

455 return ((Element es e, result), e')

445 HydrationMode_Hydrating -> do

456 HydrationMode_Hydrating -> do

@@ -469,7 +480,7 @@ makeElement elementTag cfg child = do

469 (e, eventTriggerRefs) <- readMVar wrapResult

480 (e, eventTriggerRefs) <- readMVar wrapResult

470 bracketOnError

481 bracketOnError

471 -- Run the setup, acquiring the cleanup action

482 -- Run the setup, acquiring the cleanup action

472− (triggerBody eventTriggerRefs e (WrapArg en) t)

483+ (triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t)

473 -- Run the cleanup, if we have it - but only when an exception is

484 -- Run the cleanup, if we have it - but only when an exception is

474 -- raised (we might get killed between acquiring the cleanup action

485 -- raised (we might get killed between acquiring the cleanup action

475 -- from 'triggerBody' and putting it in the MVar)

486 -- from 'triggerBody' and putting it in the MVar)

@@ -822,8 +833,17 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

822 , _selectElement_raw = undefined -- TODO domSelectElement

833 , _selectElement_raw = undefined -- TODO domSelectElement

823 }

834 }

824

835

825− placeRawElement _ = return () -- append . toNode

836+ placeRawElement = append . toNode

826− wrapRawElement e _ = return $ Element (EventSelector $ const never) e -- TODO

837+ wrapRawElement e rawCfg = do

838+ ctx <- askJSM

839+ events <- askEvents

840+ let cfg = (def :: ElementConfig EventResult t GhcjsDomSpace)

841+ { _elementConfig_modifyAttributes = _rawElementConfig_modifyAttributes rawCfg

842+ , _elementConfig_eventSpec = _rawElementConfig_eventSpec rawCfg

843+ }

844+ eventTriggerRefs <- wrap events e rawCfg

845+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e

846+ return $ Element es e

827

847

828data FragmentState

848data FragmentState

829 = FragmentState_Unmounted

849 = FragmentState_Unmounted