git.iko.soy/reflex-dom
on efaaa52 help sign in
reflex-dom/src/Reflex/Dom/Internal.hs
158 lines 7.1 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 qualified Reflex as R
19import Reflex.Dom.Builder.Immediate
20import Reflex.Dom.Class
21import Reflex.Dom.Internal.Foreign
22import Reflex.Host.Class
23import Reflex.PerformEvent.Base
24import Reflex.PostBuild.Base
25import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
26import Reflex.TriggerEvent.Base
28import Control.Concurrent
29import Control.Lens
30import Control.Monad
31import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
32import Control.Monad.Ref
33import Data.ByteString (ByteString)
34import Data.Dependent.Sum (DSum (..))
35import Data.IORef
36import Data.Maybe
37import Data.Monoid ((<>))
38import Data.Text (Text)
39import qualified Data.Text as T
40import Data.Text.Encoding
41import GHCJS.DOM hiding (runWebGUI)
42import GHCJS.DOM.Document
43import GHCJS.DOM.Element
44import GHCJS.DOM.Node
45import qualified GHCJS.DOM.Types as DOM
47{-# INLINABLE mainWidget #-}
48mainWidget :: (forall x. Widget x ()) -> IO ()
49mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
50 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
51 Just body <- getBody doc
52 attachWidget body webViewSing w
54--TODO: The x's should be unified here
55{-# INLINABLE mainWidgetWithHead #-}
56mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
57mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
58 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
59 Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
60 attachWidget headElement webViewSing h
61 Just body <- getBody doc
62 attachWidget body webViewSing b
64{-# INLINABLE mainWidgetWithCss #-}
65mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
66mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
67 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
68 Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
69 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
70 Just body <- getBody doc
71 attachWidget body webViewSing w
73type 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
75{-# INLINABLE attachWidget #-}
76attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a
77attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
79mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()
80mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do
81 let (headWidget, bodyWidget) = widgets
82 Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
83 Just headElement <- getHead doc
84 Just bodyElement <- getBody doc
85 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
86 rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a
87 a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b
88 return ((), postBuildTriggerRef)
90unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
91unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do
92 Just doc <- getOwnerDocument rootElement
93 Just df <- createDocumentFragment doc
94 let builderEnv = ImmediateDomBuilderEnv
95 { _immediateDomBuilderEnv_document = doc
96 , _immediateDomBuilderEnv_parent = toNode df
97 , _immediateDomBuilderEnv_events = events
98 }
99 result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
100 setInnerHTML rootElement $ Just ("" :: String)
101 _ <- appendChild rootElement $ Just df
102 return result
104{-# INLINABLE attachWidget' #-}
105attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
106attachWidget' rootElement wv w = attachWidget'' $ \events -> do
107 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
108 result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w
109 return (result, postBuildTriggerRef)
111type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
113{-# INLINABLE attachWidget'' #-}
114attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))
115attachWidget'' w = do
116 events <- newChan
117 (result, fc@(FireCommand fire)) <- runSpiderHost $ do
118 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
119 mPostBuildTrigger <- readRef postBuildTriggerRef
120 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
121 return (result, fc)
122 void $ forkIO $ forever $ do
123 ers <- readChan events
124 _ <- postGUISync $ runSpiderHost $ do
125 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
126 me <- readIORef er
127 return $ fmap (\e -> e :=> Identity a) me
128 _ <- fire (catMaybes mes) $ return ()
129 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
130 return ()
131 return (result, fc)
133-- | Run a reflex-dom application inside of an existing DOM element with the given ID
134mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
135mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
136 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
137 Just root <- getElementById doc eid
138 attachWidget root webViewSing w
140data AppInput t = AppInput
141 { _appInput_window :: Window t
142 }
144data AppOutput t = AppOutput --TODO: Add quit event
145 { _appOutput_windowConfig :: WindowConfig t
146 }
148runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
149runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
150 Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
151 Just body <- getBody doc
152 Just win <- getDefaultView doc
153 rec o <- attachWidget body webViewSing $ do
154 w <- lift $ wrapWindow win $ _appOutput_windowConfig o
155 app $ AppInput
156 { _appInput_window = w
157 }
158 return ()