git.iko.soy/reflex-dom
on develop help sign in
Improve specialization
64e750fRyan Trinkle
reflex-dom-core/reflex-dom-core.cabal+1
compare with develop
unifiedsplit
@@ -98,6 +98,7 @@ library
98 Reflex.Dom.Modals.Class
98 Reflex.Dom.Modals.Class
99 Reflex.Dom.Old
99 Reflex.Dom.Old
100 Reflex.Dom.Prerender
100 Reflex.Dom.Prerender
101+ Reflex.Dom.Specializations
101 Reflex.Dom.Time
102 Reflex.Dom.Time
102 Reflex.Dom.WebSocket
103 Reflex.Dom.WebSocket
103 Reflex.Dom.Widget
104 Reflex.Dom.Widget
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+10−10
@@ -196,7 +196,7 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
196instance MonadTrans (ImmediateDomBuilderT t) where
196instance MonadTrans (ImmediateDomBuilderT t) where
197 lift = ImmediateDomBuilderT . lift . lift . lift
197 lift = ImmediateDomBuilderT . lift . lift . lift
198
198
199−instance (Reflex t, MonadFix m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where
199+instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where
200 withRenderHook hook (ImmediateDomBuilderT a) = do
200 withRenderHook hook (ImmediateDomBuilderT a) = do
201 e <- ImmediateDomBuilderT ask
201 e <- ImmediateDomBuilderT ask
202 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
202 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
@@ -271,7 +271,7 @@ localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) ->
271localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
271localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
272
272
273{-# INLINABLE append #-}
273{-# INLINABLE append #-}
274−append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()
274+append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
275append n = do
275append n = do
276 p <- askParent
276 p <- askParent
277 liftJSM $ appendChild_ p n
277 liftJSM $ appendChild_ p n
@@ -282,7 +282,7 @@ textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateD
282textNodeInternal !t = do
282textNodeInternal !t = do
283 doc <- askDocument
283 doc <- askDocument
284 n <- liftJSM $ createTextNode doc t
284 n <- liftJSM $ createTextNode doc t
285− append n
285+ append $ toNode n
286 return n
286 return n
287
287
288-- | s and e must both be children of the same node and s must precede e;
288-- | s and e must both be children of the same node and s must precede e;
@@ -352,7 +352,7 @@ collectUpToGivenParent currentParent s e = do
352newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
352newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
353
353
354{-# INLINABLE wrap #-}
354{-# INLINABLE wrap #-}
355−wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
355+wrap :: forall m er t. (Reflex t, MonadFix m, MonadJSM m, MonadReflexCreateTrigger t m) => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
356wrap e cfg = do
356wrap e cfg = do
357 events <- askEvents
357 events <- askEvents
358 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
358 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
@@ -396,7 +396,7 @@ wrap e cfg = do
396 }
396 }
397
397
398{-# INLINABLE makeElement #-}
398{-# INLINABLE makeElement #-}
399−makeElement :: forall er t m a. (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m, PrimMonad m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
399+makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, MonadAdjust t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
400makeElement elementTag cfg child = do
400makeElement elementTag cfg child = do
401 doc <- askDocument
401 doc <- askDocument
402 e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
402 e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
@@ -408,7 +408,7 @@ makeElement elementTag cfg child = do
408 result <- flip localEnv child $ \env -> env
408 result <- flip localEnv child $ \env -> env
409 { _immediateDomBuilderEnv_parent = toNode e
409 { _immediateDomBuilderEnv_parent = toNode e
410 }
410 }
411− append e
411+ append $ toNode e
412 wrapped <- wrap e $ extractRawElementConfig cfg
412 wrapped <- wrap e $ extractRawElementConfig cfg
413 return ((wrapped, result), e)
413 return ((wrapped, result), e)
414
414
@@ -589,7 +589,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
589 , _selectElement_raw = domSelectElement
589 , _selectElement_raw = domSelectElement
590 }
590 }
591 return (wrapped, result)
591 return (wrapped, result)
592− placeRawElement = append
592+ placeRawElement = append . toNode
593 wrapRawElement = wrap
593 wrapRawElement = wrap
594 notReadyUntil e = do
594 notReadyUntil e = do
595 eOnce <- headE e
595 eOnce <- headE e
@@ -672,7 +672,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadFix m, Prim
672 unreadyChildren <- liftIO $ newIORef 0
672 unreadyChildren <- liftIO $ newIORef 0
673 let f = do
673 let f = do
674 result <- a0
674 result <- a0
675− append after
675+ append $ toNode after
676 return result
676 return result
677 result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
677 result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
678 { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
678 { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
@@ -903,7 +903,7 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
903 placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
903 placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
904 result' = ffor children' $ fmap $ \(_, _, _, r) -> r
904 result' = ffor children' $ fmap $ \(_, _, _, r) -> r
905 liftIO $ writeIORef placeholders $! placeholders0
905 liftIO $ writeIORef placeholders $! placeholders0
906− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append df) children0
906+ _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
907 liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
907 liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
908 requestDomAction_ $ ffor children' $ \p -> do
908 requestDomAction_ $ ffor children' $ \p -> do
909 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
909 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
@@ -993,7 +993,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
993 placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
993 placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
994 result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
994 result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
995 liftIO $ writeIORef placeholders $! placeholders0
995 liftIO $ writeIORef placeholders $! placeholders0
996− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
996+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
997 liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
997 liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
998 requestDomAction_ $ ffor children' $ \p -> do
998 requestDomAction_ $ ffor children' $ \p -> do
999 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
999 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
reflex-dom-core/src/Reflex/Dom/Main.hs+3−1
@@ -23,6 +23,8 @@ import Reflex.PostBuild.Base
23import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
23import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
24import Reflex.TriggerEvent.Base
24import Reflex.TriggerEvent.Base
25
25
26+import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported
27+
26import Control.Concurrent
28import Control.Concurrent
27import Control.Lens
29import Control.Lens
28import Control.Monad
30import Control.Monad
@@ -59,7 +61,7 @@ mainWidget' w = withJSContextSingletonMono $ \jsSing -> do
59--TODO: The x's should be unified here
61--TODO: The x's should be unified here
60{-# INLINABLE mainWidgetWithHead #-}
62{-# INLINABLE mainWidgetWithHead #-}
61mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> JSM ()
63mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> JSM ()
62−mainWidgetWithHead h b = withJSContextSingleton $ \jsSing -> do
64+mainWidgetWithHead h b = withJSContextSingletonMono $ \jsSing -> do
63 doc <- currentDocumentUnchecked
65 doc <- currentDocumentUnchecked
64 headElement <- getHeadUnchecked doc
66 headElement <- getHeadUnchecked doc
65 attachWidget headElement jsSing h
67 attachWidget headElement jsSing h
reflex-dom-core/src/Reflex/Dom/Specializations.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE RecursiveDo #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE Rank2Types #-}
8+module Reflex.Dom.Specializations where
9+
10+import Data.Text (Text)
11+import Reflex.Spider
12+import Reflex.Class
13+import Foreign.JavaScript.TH
14+import Reflex.PerformEvent.Base
15+import Reflex.PostBuild.Base
16+import Reflex.Requester.Base
17+import Reflex.TriggerEvent.Base
18+import Reflex.Dom.Builder.Class
19+import Reflex.Dom.Builder.Immediate
20+import Data.Functor.Identity
21+import Data.Functor.Compose
22+import Data.IORef
23+import GHCJS.DOM.Types (JSM)
24+import Data.IntMap.Strict (IntMap)
25+import qualified Data.IntMap.Strict as IntMap
26+import Data.FastMutableIntMap
27+
28+import qualified GHCJS.DOM.Element as DOM
29+import qualified GHCJS.DOM.Types as DOM
30+
31+{-# SPECIALIZE makeElement :: forall er a. Text -> ElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) ((Element er GhcjsDomSpace (SpiderTimeline Global), a), DOM.Element) #-}
32+
33+{-# SPECIALIZE wrap :: forall er. RawElement GhcjsDomSpace -> RawElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (Element er GhcjsDomSpace (SpiderTimeline Global)) #-}
34+
35+{-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'.
36+ ( (IntMap.Key -> ((Bool, Event (SpiderTimeline Global) ()), v) -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
37+ -> IntMap ((Bool, Event (SpiderTimeline Global) ()), v)
38+ -> Event (SpiderTimeline Global) (PatchIntMap ((Bool, Event (SpiderTimeline Global) ()), v))
39+ -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
40+ )
41+ -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
42+ -> IntMap v
43+ -> Event (SpiderTimeline Global) (PatchIntMap v)
44+ -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
45+ #-}
46+
47+{-# SPECIALIZE append :: DOM.Node -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) () #-}
48+
49+{-# SPECIALIZE drawChildUpdate :: forall k v' a. ImmediateDomBuilderEnv (SpiderTimeline Global) -> (IORef (ChildReadyState k) -> JSM ()) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a) -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a) #-}
50+
51+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust' :: forall v v'. (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v') -> IntMap v -> Event (SpiderTimeline Global) (PatchIntMap v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) #-}
52+
53+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust :: forall v v'.
54+ ( (IntMap.Key -> v -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
55+ -> IntMap v
56+ -> Event (SpiderTimeline Global) (PatchIntMap v)
57+ -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event (SpiderTimeline Global) (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
58+ )
59+ -> (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt)))
60+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ())
61+ -> (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v')
62+ -> IntMap v
63+ -> Event (SpiderTimeline Global) (PatchIntMap v)
64+ -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
65+ #-}
reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+1
@@ -138,6 +138,7 @@ listHoldWithKey m0 m' f = do
138text :: DomBuilder t m => Text -> m ()
138text :: DomBuilder t m => Text -> m ()
139text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
139text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
140
140
141+{- INLINABLE dynText #-}
141dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
142dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
142dynText t = do
143dynText t = do
143 postBuild <- getPostBuild
144 postBuild <- getPostBuild