git.iko.soy/reflex-dom
on 76ef430 help sign in
reflex-dom/src/Reflex/Dom/Internal.hs
173 lines 7.6 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE NoMonomorphismRestriction #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
14module Reflex.Dom.Internal where
16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
18import Reflex.Dom.Builder.Immediate
19import Reflex.Dom.Class
20import Reflex.Dom.Internal.Foreign
21import Reflex.Host.Class
22import Reflex.PerformEvent.Base
23import Reflex.PostBuild.Base
24import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
25import Reflex.TriggerEvent.Base
27import Control.Concurrent
28import Control.Lens
29import Control.Monad
30import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
31import Control.Monad.Ref
32import Data.ByteString (ByteString)
33import Data.Dependent.Sum (DSum (..))
34import Data.IORef
35import Data.Maybe
36import Data.Monoid ((<>))
37import Data.Text (Text)
38import qualified Data.Text as T
39import Data.Text.Encoding
40import GHCJS.DOM hiding (runWebGUI)
41import GHCJS.DOM.Document
42import GHCJS.DOM.Element
43import GHCJS.DOM.Node
44import qualified GHCJS.DOM.Types as DOM
46{-# INLINABLE mainWidget #-}
47mainWidget :: (forall x. Widget x ()) -> IO ()
48mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
49 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
50 Just body <- getBody doc
51 attachWidget body webViewSing w
53--TODO: The x's should be unified here
54{-# INLINABLE mainWidgetWithHead #-}
55mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
56mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
57 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
58 Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
59 attachWidget headElement webViewSing h
60 Just body <- getBody doc
61 attachWidget body webViewSing b
63{-# INLINABLE mainWidgetWithCss #-}
64mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
65mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
66 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
67 Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
68 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
69 Just body <- getBody doc
70 attachWidget body webViewSing w
72type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithWebView x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
74{-# INLINABLE attachWidget #-}
75attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a
76attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
78-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
79mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> IO ()
80mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingletonMono webView $ \wv -> do
81 Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
82 Just headElement <- getHead doc
83 Just headFragment <- createDocumentFragment doc
84 Just bodyElement <- getBody doc
85 Just bodyFragment <- createDocumentFragment doc
86 _ <- attachWidget'' $ \events -> do
87 let (headWidget, bodyWidget) = widgets
88 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
89 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
90 go w df = do
91 let builderEnv = ImmediateDomBuilderEnv
92 { _immediateDomBuilderEnv_document = toDocument doc
93 , _immediateDomBuilderEnv_parent = toNode df
94 , _immediateDomBuilderEnv_events = events
95 }
96 runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
97 rec b <- go (headWidget a) headFragment
98 a <- go (bodyWidget b) bodyFragment
99 return ((), postBuildTriggerRef)
100 liftIO $ replaceElementContents headElement headFragment
101 liftIO $ replaceElementContents bodyElement bodyFragment
103replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> IO ()
104replaceElementContents e df = do
105 setInnerHTML e $ Just ("" :: String)
106 _ <- appendChild e $ Just df
107 return ()
109{-# INLINABLE attachWidget' #-}
110attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
111attachWidget' rootElement wv w = do
112 Just doc <- getOwnerDocument rootElement
113 Just df <- createDocumentFragment doc
114 result <- attachWidget'' $ \events -> do
115 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
116 let builderEnv = ImmediateDomBuilderEnv
117 { _immediateDomBuilderEnv_document = toDocument doc
118 , _immediateDomBuilderEnv_parent = toNode df
119 , _immediateDomBuilderEnv_events = events
120 }
121 a <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
122 return (a, postBuildTriggerRef)
123 replaceElementContents rootElement df
124 return result
126type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
128{-# INLINABLE attachWidget'' #-}
129attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))
130attachWidget'' w = do
131 events <- newChan
132 (result, fc@(FireCommand fire)) <- runSpiderHost $ do
133 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
134 mPostBuildTrigger <- readRef postBuildTriggerRef
135 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
136 return (result, fc)
137 void $ forkIO $ forever $ do
138 ers <- readChan events
139 _ <- postGUISync $ runSpiderHost $ do
140 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
141 me <- readIORef er
142 return $ fmap (\e -> e :=> Identity a) me
143 _ <- fire (catMaybes mes) $ return ()
144 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
145 return ()
146 return (result, fc)
148-- | Run a reflex-dom application inside of an existing DOM element with the given ID
149mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
150mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
151 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
152 Just root <- getElementById doc eid
153 attachWidget root webViewSing w
155data AppInput t = AppInput
156 { _appInput_window :: Window t
157 }
159data AppOutput t = AppOutput --TODO: Add quit event
160 { _appOutput_windowConfig :: WindowConfig t
161 }
163runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
164runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
165 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
166 Just body <- getBody doc
167 Just win <- getDefaultView doc
168 rec o <- attachWidget body webViewSing $ do
169 w <- lift $ wrapWindow win $ _appOutput_windowConfig o
170 app $ AppInput
171 { _appInput_window = w
172 }
173 return ()