@@ -0,0 +1,116 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Reflex.Dom.Builder.Hydratable where
10+
11+import Control.Monad.Fix
12+import Control.Monad.Primitive
13+import Control.Monad.Ref
14+import Control.Monad.Trans
15+import Control.Monad.Trans.Control
16+import Data.Coerce
17+import qualified Data.Map as Map
18+import Foreign.JavaScript.TH
19+#ifndef ghcjs_HOST_OS
20+import GHCJS.DOM.Types (MonadJSM (..))
21+#endif
22+import Reflex
23+import Reflex.Dom.Builder.Class
24+import Reflex.Dom.Builder.Immediate (HasDocument (..))
25+import Reflex.Host.Class
26+
27+-- | A DomBuilder transformer that adds "data-ssr" to all elements such that the
28+-- hydration builder knows which bits of DOM were added by us, and which were
29+-- added by external scripts.
30+newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
31+
32+#ifndef ghcjs_HOST_OS
33+instance MonadJSM m => MonadJSM (HydratableT m) where
34+ liftJSM' = HydratableT . liftJSM'
35+#endif
36+
37+deriving instance MonadSample t m => MonadSample t (HydratableT m)
38+deriving instance MonadHold t m => MonadHold t (HydratableT m)
39+
40+instance MonadTrans HydratableT where
41+ lift = HydratableT
42+
43+instance MonadTransControl HydratableT where
44+ type StT HydratableT a = a
45+ liftWith f = HydratableT $ f runHydratableT
46+ restoreT = HydratableT
47+
48+instance MonadRef m => MonadRef (HydratableT m) where
49+ type Ref (HydratableT m) = Ref m
50+ newRef = lift . newRef
51+ readRef = lift . readRef
52+ writeRef ref = lift . writeRef ref
53+
54+instance PerformEvent t m => PerformEvent t (HydratableT m) where
55+ type Performable (HydratableT m) = Performable m
56+ performEvent_ = lift . performEvent_
57+ performEvent = lift . performEvent
58+
59+instance PrimMonad m => PrimMonad (HydratableT m) where
60+ type PrimState (HydratableT m) = PrimState m
61+ primitive = lift . primitive
62+
63+makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m
64+makeHydratable cfg = cfg
65+ { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg
66+ , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg
67+ }
68+
69+instance PostBuild t m => PostBuild t (HydratableT m) where
70+ getPostBuild = lift getPostBuild
71+
72+deriving instance TriggerEvent t m => TriggerEvent t (HydratableT m)
73+
74+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydratableT m) where
75+ newEventWithTrigger = lift . newEventWithTrigger
76+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
77+
78+instance Adjustable t m => Adjustable t (HydratableT m) where
79+ runWithReplace a0 a' = HydratableT $ runWithReplace (coerce a0) (coerceEvent a')
80+ traverseDMapWithKeyWithAdjust f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')
81+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')
82+ traverseIntMapWithKeyWithAdjust f m0 m' = HydratableT $ traverseIntMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce m0) (coerceEvent m')
83+
84+instance NotReady t m => NotReady t (HydratableT m) where
85+ notReadyUntil = lift . notReadyUntil
86+ notReady = lift notReady
87+
88+instance DomBuilder t m => DomBuilder t (HydratableT m) where
89+ type DomBuilderSpace (HydratableT m) = DomBuilderSpace m
90+ element t cfg = lift . element t (makeHydratable cfg) . runHydratableT
91+ inputElement cfg = lift $ inputElement $ cfg
92+ { _inputElementConfig_elementConfig = makeHydratable $ _inputElementConfig_elementConfig cfg
93+ }
94+ textAreaElement cfg = lift $ textAreaElement $ cfg
95+ { _textAreaElementConfig_elementConfig = makeHydratable $ _textAreaElementConfig_elementConfig cfg
96+ }
97+ selectElement cfg child = do
98+ let cfg' = cfg
99+ { _selectElementConfig_elementConfig = makeHydratable $ _selectElementConfig_elementConfig cfg
100+ }
101+ lift $ selectElement cfg' $ runHydratableT child
102+
103+instance HasDocument m => HasDocument (HydratableT m)
104+
105+instance HasJSContext m => HasJSContext (HydratableT m) where
106+ type JSContextPhantom (HydratableT m) = JSContextPhantom m
107+ askJSContext = lift askJSContext
108+
109+instance HasJS js m => HasJS js (HydratableT m) where
110+ type JSX (HydratableT m) = JSX m
111+ liftJS = lift . liftJS
112+
113+instance DomRenderHook t m => DomRenderHook t (HydratableT m) where
114+ withRenderHook f = HydratableT . withRenderHook f . runHydratableT
115+ requestDomAction = HydratableT . requestDomAction
116+ requestDomAction_ = HydratableT . requestDomAction_