@@ -1,4 +1,5 @@
11{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE EmptyCase #-}
23{-# LANGUAGE EmptyDataDecls #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
@@ -26,6 +27,7 @@ import Control.Monad.Reader
2627import Control.Monad.Ref (MonadRef(..))
2728import Data.IORef (IORef, newIORef)
2829import Data.Text (Text)
30+import Data.Void
2931import Foreign.JavaScript.TH
3032import GHCJS.DOM.Types (MonadJSM)
3133import Reflex hiding (askEvents)
@@ -48,7 +50,7 @@ type PrerenderClientConstraint js t m =
4850 , DomRenderHook t m
4951 , HasDocument m
5052 , TriggerEvent t m
51− , Prerender js t m
53+ -- , Prerender js t m
5254 , PrerenderBaseConstraints js t m
5355 )
5456
@@ -76,16 +78,16 @@ type PrerenderBaseConstraints js t m =
7678-- hydration builder will run *both* widgets.
7779prerender_
7880 :: (Functor m, Reflex t, Prerender js t m)
79− => m () -> ((PrerenderClientConstraint js t (Client m)) => Client m ()) -> m ()
81+ => m () -> Client m () -> m ()
8082prerender_ server client = void $ prerender server client
8183
82−class Prerender js t m | m -> t js where
84+class PrerenderClientConstraint js t (Client m) => Prerender js t m | m -> t js where
8385 -- | Monad in which the client widget is built
8486 type Client m :: * -> *
8587 -- | Render the first widget on the server, and the second on the client. The
8688 -- hydration builder will run *both* widgets, updating the result dynamic at
8789 -- switchover time.
88− prerender :: m a -> ((PrerenderClientConstraint js t (Client m)) => Client m a) -> m (Dynamic t a)
90+ prerender :: m a -> Client m a -> m (Dynamic t a)
8991
9092instance (ReflexHost t, Adjustable t m, PrerenderBaseConstraints js t m) => Prerender js t (HydrationDomBuilderT GhcjsDomSpace t m) where
9193 type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m
@@ -130,10 +132,72 @@ instance (Adjustable t m, PrerenderBaseConstraints js t m, ReflexHost t) => Prer
130132 insertBefore df =<< deleteToPrerenderEnd doc
131133 holdDyn a0 a'
132134
133−data NoJavaScript -- This type should never have a HasJS instance
135+newtype UnrunnableT t m a = UnrunnableT { runUnrunnableT :: Void -> m a }
134136
135−instance (js ~ NoJavaScript, SupportsStaticDomBuilder t m) => Prerender js t (StaticDomBuilderT t m) where
136− type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m
137+instance Functor (UnrunnableT t m) where
138+ fmap _ _ = UnrunnableT $ \case
139+instance Applicative (UnrunnableT t m) where
140+ pure _ = UnrunnableT $ \case
141+ _ <*> _ = UnrunnableT $ \case
142+instance Monad (UnrunnableT t m) where
143+ _ >>= _ = UnrunnableT $ \case
144+instance MonadTrans (UnrunnableT t) where
145+ lift _ = UnrunnableT $ \case
146+instance Reflex t => DomBuilder t (UnrunnableT t m) where
147+ type DomBuilderSpace (UnrunnableT t m) = GhcjsDomSpace
148+ textNode _ = UnrunnableT $ \case
149+ commentNode _ = UnrunnableT $ \case
150+ element _ _ _ = UnrunnableT $ \case
151+ inputElement _ = UnrunnableT $ \case
152+ textAreaElement _ = UnrunnableT $ \case
153+ selectElement _ _ = UnrunnableT $ \case
154+ placeRawElement _ = UnrunnableT $ \case
155+ wrapRawElement _ _ = UnrunnableT $ \case
156+instance NotReady t (UnrunnableT t m) where
157+ notReadyUntil _ = UnrunnableT $ \case
158+ notReady = UnrunnableT $ \case
159+instance Reflex t => Adjustable t (UnrunnableT t m) where
160+ runWithReplace _ _ = UnrunnableT $ \case
161+ traverseIntMapWithKeyWithAdjust _ _ _ = UnrunnableT $ \case
162+ traverseDMapWithKeyWithAdjust _ _ _ = UnrunnableT $ \case
163+ traverseDMapWithKeyWithAdjustWithMove _ _ _ = UnrunnableT $ \case
164+instance Reflex t => PerformEvent t (UnrunnableT t m) where
165+ type Performable (UnrunnableT t m) = UnrunnableT t m
166+ performEvent _ = UnrunnableT $ \case
167+ performEvent_ _ = UnrunnableT $ \case
168+instance MonadRef (UnrunnableT t m) where
169+ type Ref (UnrunnableT t m) = Ref IO
170+ newRef _ = UnrunnableT $ \case
171+ readRef _ = UnrunnableT $ \case
172+ writeRef _ _ = UnrunnableT $ \case
173+instance HasDocument (UnrunnableT t m) where
174+ askDocument = UnrunnableT $ \case
175+instance HasJSContext (UnrunnableT t m) where
176+ --type JsContextPhantom (UnrunnableT t m) = ()
177+instance HasJS JS' (UnrunnableT t m) where
178+ type JSX (UnrunnableT t m) = UnrunnableT t m
179+instance MonadJS JS' (UnrunnableT t m) where
180+instance TriggerEvent t (UnrunnableT t m) where
181+instance MonadReflexCreateTrigger t (UnrunnableT t m) where
182+ newEventWithTrigger _ = UnrunnableT $ \case
183+instance MonadFix (UnrunnableT t m) where
184+ mfix _ = UnrunnableT $ \case
185+instance MonadHold t (UnrunnableT t m) where
186+ hold _ _ = UnrunnableT $ \case
187+ holdDyn _ _ = UnrunnableT $ \case
188+ holdIncremental _ _ = UnrunnableT $ \case
189+instance MonadSample t (UnrunnableT t m)
190+instance MonadIO (UnrunnableT t m)
191+instance MonadJSM (UnrunnableT t m) where
192+ liftJSM' _ = UnrunnableT $ \case
193+instance Reflex t => PostBuild t (UnrunnableT t m)
194+instance PrimMonad (UnrunnableT t m) where
195+-- type RawDocument (UnrunnableT t m) = DOM.Document
196+--instance HasJSContext (UnrunnableT t m)
197+--instance MonadJSM (UnrunnableT t m)
198+
199+instance (SupportsStaticDomBuilder t m) => Prerender JS' t (StaticDomBuilderT t m) where
200+ type Client (StaticDomBuilderT t m) = UnrunnableT t m
137201 prerender server _ = do
138202 _ <- commentNode $ CommentNodeConfig startMarker Nothing
139203 a <- server