bf99e40 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge develop into ghcjs-dom-update

commitbf99e404139b0055ca1fb069b98fb76b0c5ddfce authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateTue 15 Nov 2016, 23:46 (10 years ago) parent106c032 66b6d35

13 files changed+54−40

compare with develop

unifiedsplit

reflex-dom.cabal+1 src/Foreign/JavaScript/TH.hs+5−4 src/Reflex/Dom.hs+1−1 src/Reflex/Dom/Builder/Class.hs+6−6 src/Reflex/Dom/Builder/Immediate.hs+12−9 src/Reflex/Dom/Builder/Static.hs+2−1 src/Reflex/Dom/Internal.hs+20−17 src/Reflex/Dom/Old.hs+1 src/Reflex/Dom/Time.hs+2−1 src/Reflex/Dom/WebSocket.hs+1 src/Reflex/Dom/Widget/Input.hs+1−1 src/Reflex/Dom/Widget/Resize.hs+1 src/Reflex/Dom/Xhr.hs+1

reflex-dom.cabal+1

@@ -100,6 +100,7 @@ library

100100-- Reflex.Dom.Xhr.Exception

101101

102102 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

103+

103104 if flag(use-reflex-optimizer)

104105 ghc-options: -fplugin=Reflex.Optimizer

105106

src/Foreign/JavaScript/TH.hs+5−4

@@ -25,7 +25,8 @@ import Reflex.DynamicWriter

2525import Reflex.Host.Class

2626import Reflex.PerformEvent.Base

2727import Reflex.PerformEvent.Class

28−import Reflex.PostBuild.Class

28+import Reflex.PostBuild.Base

29+import Reflex.Requester.Base

2930

3031import Language.Haskell.TH

3132

@@ -49,7 +50,6 @@ import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer

4950

5051import Data.Hashable

5152import Data.Word

52−import Data.Coerce (coerce)

5353import Foreign.C.Types

5454import Foreign.Ptr

5555import Text.Encoding.Z

@@ -76,6 +76,7 @@ import qualified Control.Monad.State.Strict as Strict

7676import Control.Monad.Trans.Control

7777import Data.ByteString (ByteString)

7878import qualified Data.ByteString as BS

79+import Data.Coerce (coerce)

7980import Data.Monoid

8081import Data.Text (Text)

8182import qualified Data.Text as T

@@ -222,8 +223,8 @@ instance HasJS x m => HasJS x (DynamicWriterT t w m) where

222223 type JSX (DynamicWriterT t w m) = JSX m

223224 liftJS = lift . liftJS

224225

225−instance HasJS x m => HasJS x (RequestT t request response m) where

226− type JSX (RequestT t request response m) = JSX m

226+instance HasJS x m => HasJS x (RequesterT t request response m) where

227+ type JSX (RequesterT t request response m) = JSX m

227228 liftJS = lift . liftJS

228229

229230-- | A Monad that is capable of executing JavaScript

src/Reflex/Dom.hs+1−1

@@ -1,6 +1,6 @@

11module Reflex.Dom (module X) where

3−import Reflex as X

3+import Reflex as X hiding (askEvents)

44import Reflex.Dom.Builder.Class as X

55import Reflex.Dom.Builder.Immediate as X

66import Reflex.Dom.Builder.InputDisabled as X

src/Reflex/Dom/Builder/Class.hs+6−6

@@ -22,9 +22,9 @@ module Reflex.Dom.Builder.Class

2222import Reflex.Class as Reflex

2323import Reflex.Dom.Builder.Class.Events

2424import Reflex.DynamicWriter

25−import Reflex.PerformEvent.Base

2625import Reflex.PerformEvent.Class

27−import Reflex.PostBuild.Class

26+import Reflex.PostBuild.Base

27+import Reflex.Requester.Base

2828

2929import qualified Control.Category

3030import Control.Lens hiding (element)

@@ -520,10 +520,10 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

520520 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

521521 }

522522

523−instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequestT t request response m) where

524− type DomBuilderSpace (RequestT t request response m) = DomBuilderSpace m

523+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT t request response m) where

524+ type DomBuilderSpace (RequesterT t request response m) = DomBuilderSpace m

525525 textNode = liftTextNode

526− element elementTag cfg (RequestT child) = RequestT $ do

526+ element elementTag cfg (RequesterT child) = RequesterT $ do

527527 r <- ask

528528 s <- get

529529 let cfg' = liftElementConfig cfg

@@ -532,7 +532,7 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequestT t

532532 return (el, a)

533533 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig

534534 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig

535− selectElement cfg (RequestT child) = RequestT $ do

535+ selectElement cfg (RequesterT child) = RequesterT $ do

536536 r <- ask

537537 s <- get

538538 let cfg' = cfg & selectElementConfig_elementConfig %~ liftElementConfig

src/Reflex/Dom/Builder/Immediate.hs+12−9

@@ -24,6 +24,8 @@ import Reflex.Dynamic

2424import Reflex.Host.Class

2525import Reflex.PerformEvent.Class

2626import Reflex.PostBuild.Class

27+import Reflex.TriggerEvent.Class

28+import Reflex.TriggerEvent.Base hiding (askEvents)

2729

2830import Control.Concurrent.Chan

2931import Control.Lens hiding (element)

@@ -58,8 +60,9 @@ import qualified GHCJS.DOM.HTMLInputElement as Input

5860import qualified GHCJS.DOM.HTMLSelectElement as Select

5961import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

6062import GHCJS.DOM.MouseEvent

61−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,

63+import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling,

6264 removeChild, setNodeValue, toNode)

65+import qualified GHCJS.DOM.Node as DOM (insertBefore)

6366import GHCJS.DOM.Types

6467 (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),

6568 FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,

@@ -72,8 +75,6 @@ import Debug.Trace hiding (traceEvent)

7275

7376data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }

7477

75−data TriggerInvocation a = TriggerInvocation a (JSM ())

76−

7778data ImmediateDomBuilderEnv t

7879 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

7980 , _immediateDomBuilderEnv_parent :: Node

@@ -143,7 +144,7 @@ deleteBetweenInclusive s e = do

143144 return ()

144145

145146-- | s and e must both be children of the same node and s must precede e

146−deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

147+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

147148deleteBetweenExclusive s e = do

148149 mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

149150 case mCurrentParent of

@@ -161,7 +162,7 @@ deleteBetweenExclusive s e = do

161162

162163-- | s and e must both be children of the same node and s must precede e; s and all nodes between s and e will be removed, but e will not be removed

163164{-# INLINABLE deleteUpTo #-}

164−deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

165+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

165166deleteUpTo s e = do

166167 mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

167168 case mCurrentParent of

@@ -169,14 +170,16 @@ deleteUpTo s e = do

169170 Just currentParent -> deleteUpToGivenParent currentParent s e

170171

171172{-# INLINABLE deleteUpToGivenParent #-}

172−deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

173+deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

173174deleteUpToGivenParent currentParent s e = do

174175 fix $ \loop -> do

175176 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

176177 _ <- removeChild currentParent $ Just x

177− when (toNode s /= toNode x) loop

178+ liftJSM (strictEqual s x) >>= \case

179+ True -> return ()

180+ False -> loop

178181

179−type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref JSM)

182+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m)

180183

181184newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

182185

@@ -417,7 +420,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

417420 placeRawElement = append

418421 wrapRawElement = wrap

419422

420−instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

423+instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

421424 runWithReplace a0 a' = do

422425 initialEnv <- ImmediateDomBuilderT ask

423426 before <- textNodeInternal ("" :: Text)

src/Reflex/Dom/Builder/Static.hs+2−1

@@ -46,8 +46,9 @@ import Reflex.Dynamic

4646import Reflex.Host.Class

4747import Reflex.PerformEvent.Base

4848import Reflex.PerformEvent.Class

49−import Reflex.PostBuild.Class

49+import Reflex.PostBuild.Base

5050import Reflex.Spider

51+import Reflex.TriggerEvent.Class

5152

5253newtype StaticDomBuilderT t m a = StaticDomBuilderT

5354 { unStaticDomBuilderT :: StateT [Behavior t Builder] m a -- Accumulated Html will be in reversed order

src/Reflex/Dom/Internal.hs+20−17

@@ -22,8 +22,9 @@ import Reflex.Dom.Builder.Immediate

2222import Reflex.Dom.Class

2323import Reflex.Host.Class

2424import Reflex.PerformEvent.Base

25−import Reflex.PostBuild.Class

25+import Reflex.PostBuild.Base

2626import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

27+import Reflex.TriggerEvent.Base

2728

2829import Control.Concurrent

2930import Control.Lens

@@ -89,21 +90,23 @@ instance MonadJSM m => MonadJSM (PostBuildT t m) where

8990

9091{-# INLINABLE attachWidget #-}

9192attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

92−attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w

93−

94−mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()

95−mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do

93+attachWidget rootElement wv w = liftIO $ fst <$> attachWidget' rootElement wv w

94+

95+mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> JSM ()

96+mainWidgetWithHead' widgets = withJSContextSingleton $ \jsSing -> do

97+ Just doc <- currentDocument

98+ Just headElement <- getHead doc

99+ Just bodyElement <- getBody doc

100+-- runWebGUI $ \webView -> withWebViewSingleton webView $ \wv ->

101+ liftIO $ fmap fst $ attachWidget'' $ \events -> do

96102 let (headWidget, bodyWidget) = widgets

97− Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

98− Just headElement <- getHead doc

99− Just bodyElement <- getBody doc

100103 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

101− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a

102− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b

104+ rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement jsSing $ headWidget a

105+ a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement jsSing $ bodyWidget b

103106 return ((), postBuildTriggerRef)

104107

105−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

106−unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do

108+unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> JSContextSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

109+unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w = (`runWithJSContextSingleton` jsSing) $ do

107110 Just doc <- getOwnerDocument rootElement

108111 Just df <- createDocumentFragment doc

109112 let builderEnv = ImmediateDomBuilderEnv

@@ -111,16 +114,16 @@ unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do

111114 , _immediateDomBuilderEnv_parent = toNode df

112115 , _immediateDomBuilderEnv_events = events

113116 }

114− result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

117+ result <- runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv

115118 setInnerHTML rootElement $ Just ("" :: String)

116119 _ <- appendChild rootElement $ Just df

117120 return result

118121

119122{-# INLINABLE attachWidget' #-}

120−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

121−attachWidget' rootElement wv w = attachWidget'' $ \events -> do

123+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

124+attachWidget' rootElement jsSing w = attachWidget'' $ \events -> do

122125 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

123− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w

126+ result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w

124127 return (result, postBuildTriggerRef)

125128

126129type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

@@ -141,7 +144,7 @@ attachWidget'' w = do

141144 me <- readIORef er

142145 return $ fmap (\e -> e :=> Identity a) me

143146 _ <- fire (catMaybes mes) $ return ()

144− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> (`runJSM` ctx) cb

147+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

145148 return ()

146149 return (result, fc)

147150

src/Reflex/Dom/Old.hs+1

@@ -73,6 +73,7 @@ import Reflex.Dom.Widget.Basic

7373import Reflex.Host.Class

7474import Reflex.PerformEvent.Class

7575import Reflex.PostBuild.Class

76+import Reflex.TriggerEvent.Class

7677

7778data ElConfig attrs = ElConfig

7879 { _elConfig_namespace :: Maybe Text

src/Reflex/Dom/Time.hs+2−1

@@ -10,6 +10,7 @@ import Reflex.Class

1010import Reflex.Dynamic

1111import Reflex.PerformEvent.Class

1212import Reflex.PostBuild.Class

13+import Reflex.TriggerEvent.Class

1314

1415import Control.Concurrent

1516import qualified Control.Concurrent.Thread.Delay as Concurrent

@@ -33,7 +34,7 @@ data TickInfo

3334

3435-- | Special case of tickLossyFrom that uses the post-build event to start the

3536-- tick thread.

36−tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadJSM (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

37+tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

3738tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild

3839

3940-- | Send events over time with the given basis time and interval

src/Reflex/Dom/WebSocket.hs+1

@@ -28,6 +28,7 @@ import Reflex.Dom.Class

2828import Reflex.Dom.WebSocket.Foreign

2929import Reflex.PerformEvent.Class

3030import Reflex.PostBuild.Class

31+import Reflex.TriggerEvent.Class

3132

3233import Control.Concurrent

3334import Control.Concurrent.STM

src/Reflex/Dom/Widget/Input.hs+1−1

@@ -42,8 +42,8 @@ import Reflex.Dom.Builder.Immediate

4242import Reflex.Dom.Class

4343import Reflex.Dom.Widget.Basic

4444import Reflex.Dynamic

45−import Reflex.PerformEvent.Class

4645import Reflex.PostBuild.Class

46+import Reflex.TriggerEvent.Class

4747import qualified Text.Read as T

4848

4949import qualified GHCJS.DOM.Event as Event

src/Reflex/Dom/Widget/Resize.hs+1

@@ -13,6 +13,7 @@ import Reflex.Dom.Class

1313import Reflex.Dom.Widget.Basic

1414import Reflex.PerformEvent.Class

1515import Reflex.PostBuild.Class

16+import Reflex.TriggerEvent.Class

1617

1718import Control.Monad

1819import Control.Monad.Fix

src/Reflex/Dom/Xhr.hs+1

@@ -62,6 +62,7 @@ where

6262import Reflex.Class

6363import Reflex.Dom.Class

6464import Reflex.PerformEvent.Class

65+import Reflex.TriggerEvent.Class

6566

6667import Control.Concurrent

6768import Control.Exception (handle)