git.iko.soy/reflex-dom
on d16fa53 help sign in
2236067
swap
0 ahead, 54 behind
.github/workflows/haskell.ymldeleted−47
since splitsnapshots
unifiedsplit
@@ -1,47 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− exclude:
12− # There are some linker warnings in 802 on darwin that
13− # cause compilation to fail
14− # See https://github.com/NixOS/nixpkgs/issues/25139
15− - ghc: '8.0.2'
16− os: 'macos-latest'
17− runs-on: ${{ matrix.os }}
18−
19− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
20− steps:
21− - uses: actions/checkout@v2
22− - uses: actions/setup-haskell@v1
23− with:
24− ghc-version: ${{ matrix.ghc }}
25− - name: Cache
26− uses: actions/cache@v1
27− env:
28− cache-name: cache-cabal
29− with:
30− path: ~/.cabal
31− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
32− restore-keys: |
33− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
34− ${{ runner.os }}-${{ matrix.ghc }}-build-
35− ${{ runner.os }}-${{ matrix.ghc }}-
36− ${{ runner.os }}
37−
38− - name: Set up cabal project file to avoid webkit2gtk
39− run: cp cabal.project-nogtk cabal.project
40− - name: Install dependencies
41− run: |
42− cabal update
43− cabal build --only-dependencies --enable-tests --enable-benchmarks all
44− - name: Build
45− run: cabal build --enable-tests --enable-benchmarks all
46− - name: Run tests
47− run: cabal test all
cabal.project+1−10
@@ -1,10 +1 @@
1−packages:
2− reflex-dom-core/
1+packages: reflex-dom-core, reflex-dom
3− reflex-dom/
4− chrome-test-utils/
5− reflex-dom-test-selenium/
6−
7−source-repository-package
8− type: git
9− location: https://github.com/dfordivam/hspec-webdriver-clone
10− tag: 0d748b7bb7cd74dce0a55a1ec86b01dbb8a71cd8
cabal.project-nogtkdeleted−14
@@ -1,14 +0,0 @@
1−packages:
2− reflex-dom-core/
3− reflex-dom/
4−
5−package reflex-dom-core
6− flags: -hydration-tests -gc-tests
7−
8−package reflex-dom
9− flags: +use-warp -webkit2gtk
10−
11−source-repository-package
12− type: git
13− location: https://github.com/dfordivam/hspec-webdriver-clone
14− tag: 0d748b7bb7cd74dce0a55a1ec86b01dbb8a71cd8
reflex-dom-core/ChangeLog.md−8
@@ -1,13 +1,5 @@
1# Revision history for reflex-dom-core
1# Revision history for reflex-dom-core
2
2
3−## 0.6.2.1
4−
5−* Fix hlint complaints with newer GHC.
6−
7−## 0.6.2.0
8−
9−* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer
10−
11## 0.6.1.0
3## 0.6.1.0
12
4
13* Bump version bounds
5* Bump version bounds
reflex-dom-core/reflex-dom-core.cabal+7−19
@@ -1,6 +1,6 @@
1cabal-version: 1.24
1cabal-version: 1.24
2Name: reflex-dom-core
2Name: reflex-dom-core
3−Version: 0.6.2.1
3+Version: 0.6.1.0
4Synopsis: Functional Reactive Web Apps with Reflex
4Synopsis: Functional Reactive Web Apps with Reflex
5Description:
5Description:
6 Web applications without callbacks or side-effects.
6 Web applications without callbacks or side-effects.
@@ -54,21 +54,11 @@ flag split-these
54 manual: False
54 manual: False
55 default: True
55 default: True
56
56
57−flag hydration-tests
58− description: Whether to run the hydration tests (currently only available on linux)
59− default: True
60− manual: True
61−
62−flag gc-tests
63− description: Whether to run the gc tests (currently only available on linux)
64− default: True
65− manual: True
66−
67library
57library
68 hs-source-dirs: src
58 hs-source-dirs: src
69 build-depends:
59 build-depends:
70− aeson >= 0.8 && < 1.6,
60+ aeson >= 0.8 && < 1.5,
71− base >= 4.7 && < 4.15,
61+ base >= 4.7 && < 4.14,
72 bifunctors >= 4.2 && < 6,
62 bifunctors >= 4.2 && < 6,
73 bimap >= 0.3 && < 0.5,
63 bimap >= 0.3 && < 0.5,
74 blaze-builder >= 0.4.1 && < 0.5,
64 blaze-builder >= 0.4.1 && < 0.5,
@@ -169,16 +159,14 @@ library
169 if flag(use-template-haskell)
159 if flag(use-template-haskell)
170 build-depends:
160 build-depends:
171 dependent-sum-template >= 0.1 && < 0.2,
161 dependent-sum-template >= 0.1 && < 0.2,
172− template-haskell >= 2.12.0 && < 2.17
162+ template-haskell >= 2.12.0 && < 2.16
173 other-extensions: TemplateHaskell
163 other-extensions: TemplateHaskell
174 cpp-options: -DUSE_TEMPLATE_HASKELL
164 cpp-options: -DUSE_TEMPLATE_HASKELL
175 other-modules:
165 other-modules:
176 Reflex.Dom.Builder.Class.TH
166 Reflex.Dom.Builder.Class.TH
177
167
178test-suite hlint
168test-suite hlint
179− build-depends:
169+ build-depends: base, hlint
180− base,
181− hlint >= 2.0 && < 4.0
182 hs-source-dirs: test
170 hs-source-dirs: test
183 main-is: hlint.hs
171 main-is: hlint.hs
184 type: exitcode-stdio-1.0
172 type: exitcode-stdio-1.0
@@ -230,7 +218,7 @@ test-suite hydration
230 main-is: hydration.hs
218 main-is: hydration.hs
231 type: exitcode-stdio-1.0
219 type: exitcode-stdio-1.0
232 default-language: Haskell98
220 default-language: Haskell98
233− if !os(linux) || !arch(x86_64) || flag(profile-reflex) || !flag(hydration-tests)
221+ if !os(linux) || !arch(x86_64) || flag(profile-reflex)
234 buildable: False
222 buildable: False
235
223
236-- broken test on base 4.11 & ghc 8.4.3
224-- broken test on base 4.11 & ghc 8.4.3
@@ -250,7 +238,7 @@ test-suite gc
250 main-is: gc.hs
238 main-is: gc.hs
251 type: exitcode-stdio-1.0
239 type: exitcode-stdio-1.0
252 default-language: Haskell98
240 default-language: Haskell98
253− if !os(linux) || !arch(x86_64) || !flag(gc-tests)
241+ if !os(linux) || !arch(x86_64)
254 buildable: False
242 buildable: False
255
243
256source-repository head
244source-repository head
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+1−2
@@ -9,12 +9,11 @@
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10#if !MIN_VERSION_base(4,9,0)
10#if !MIN_VERSION_base(4,9,0)
11{-# LANGUAGE ImpredicativeTypes #-}
11{-# LANGUAGE ImpredicativeTypes #-}
12−#else
13−{-# LANGUAGE Rank2Types #-} -- Implied by ImpredicativeTypes
14#endif
12#endif
15{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE LambdaCase #-}
16{-# LANGUAGE OverloadedStrings #-}
14{-# LANGUAGE OverloadedStrings #-}
17{-# LANGUAGE PolyKinds #-}
15{-# LANGUAGE PolyKinds #-}
16+{-# LANGUAGE Rank2Types #-}
18{-# LANGUAGE RecursiveDo #-}
17{-# LANGUAGE RecursiveDo #-}
19{-# LANGUAGE ScopedTypeVariables #-}
18{-# LANGUAGE ScopedTypeVariables #-}
20{-# LANGUAGE StandaloneDeriving #-}
19{-# LANGUAGE StandaloneDeriving #-}
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+17−55
@@ -2,6 +2,7 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
@@ -48,7 +49,6 @@ module Reflex.Dom.Builder.Immediate
48 , HydrationMode (..)
49 , HydrationMode (..)
49 , HydrationRunnerT (..)
50 , HydrationRunnerT (..)
50 , runHydrationRunnerT
51 , runHydrationRunnerT
51− , runHydrationRunnerTWithFailure
52 , ImmediateDomBuilderT
52 , ImmediateDomBuilderT
53 , runHydrationDomBuilderT
53 , runHydrationDomBuilderT
54 , getHydrationMode
54 , getHydrationMode
@@ -294,21 +294,12 @@ localRunner (HydrationRunnerT m) s parent = do
294runHydrationRunnerT
294runHydrationRunnerT
295 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
295 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
296 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
296 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
297−runHydrationRunnerT m = runHydrationRunnerTWithFailure m (pure ())
298−
299−{-# INLINABLE runHydrationRunnerTWithFailure #-}
300−runHydrationRunnerTWithFailure
301− :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
302− => HydrationRunnerT t m a -> IO () -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
303−runHydrationRunnerTWithFailure (HydrationRunnerT m) onFailure s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
297+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
304 (a, s') <- runStateT m (HydrationState s False)
298 (a, s') <- runStateT m (HydrationState s False)
305 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
299 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
306 when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
300 when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
307− when (_hydrationState_failed s') $ liftIO onFailure
308 pure a
301 pure a
309
302
310−
311−
312instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
303instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
313 {-# INLINABLE newEventWithTrigger #-}
304 {-# INLINABLE newEventWithTrigger #-}
314 newEventWithTrigger = lift . newEventWithTrigger
305 newEventWithTrigger = lift . newEventWithTrigger
@@ -332,7 +323,7 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
332-- done *before* the switchover to immediate mode - this is most likely some
323-- done *before* the switchover to immediate mode - this is most likely some
333-- form of 'hold' which we want to remove after hydration is done
324-- form of 'hold' which we want to remove after hydration is done
334{-# INLINABLE addHydrationStepWithSetup #-}
325{-# INLINABLE addHydrationStepWithSetup #-}
335−addHydrationStepWithSetup :: MonadIO m => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
326+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
336addHydrationStepWithSetup setup f = getHydrationMode >>= \case
327addHydrationStepWithSetup setup f = getHydrationMode >>= \case
337 HydrationMode_Immediate -> pure ()
328 HydrationMode_Immediate -> pure ()
338 HydrationMode_Hydrating -> do
329 HydrationMode_Hydrating -> do
@@ -937,26 +928,14 @@ inputElementInternal cfg = getHydrationMode >>= \case
937 doc <- askDocument
928 doc <- askDocument
938 -- Expected initial value from config
929 -- Expected initial value from config
939 let v0 = _inputElementConfig_initialValue cfg
930 let v0 = _inputElementConfig_initialValue cfg
940− c0 = _inputElementConfig_initialChecked cfg
931+ addHydrationStep $ do
941− valuesAtSwitchover = do
942− v <- maybe (pure $ pure v0) (hold v0) (_inputElementConfig_setValue cfg)
943− c <- maybe (pure $ pure c0) (hold c0) (_inputElementConfig_setChecked cfg)
944− pure (v, c)
945− addHydrationStepWithSetup valuesAtSwitchover $ \(switchoverValue', switchoverChecked') -> do
946− switchoverValue <- sample switchoverValue'
947− switchoverChecked <- sample switchoverChecked'
948 domElement <- liftIO $ readIORef domElementRef
932 domElement <- liftIO $ readIORef domElementRef
949 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
933 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
950 getValue = Input.getValue domInputElement
934 getValue = Input.getValue domInputElement
951− -- When the value has been updated by setValue before switchover, we must
935+ -- The browser might have messed with the value, or the user could have
952− -- send an update here to remain in sync. This is because the later
936+ -- altered it before activation, so we set it if it isn't what we expect
953− -- requestDomAction based on the setValue event will not capture events
937+ liftJSM getValue >>= \v0' -> do
954− -- happening before postBuild, because this code runs after switchover.
955− when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
956− -- The user could have altered the value before switchover. This must be
957− -- triggered after the setValue one in order for the events to be in the
958− -- correct order.
959− liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
938+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
960 -- Watch for user interaction and trigger event accordingly
939 -- Watch for user interaction and trigger event accordingly
961 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
940 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
962 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
941 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
@@ -970,17 +949,7 @@ inputElementInternal cfg = getHydrationMode >>= \case
970 ]
949 ]
971 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
950 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
972 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
951 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
973− -- When the checked state has been updated by setChecked before
952+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
974− -- switchover, we must send an update here to remain in sync. This is
975− -- because the later requestDomAction based on the setChecked event will not
976− -- capture events happening before postBuild, because this code runs after
977− -- switchover.
978− when (c0 /= switchoverChecked) $ liftIO $ triggerCheckedChangedBySetChecked switchoverChecked
979− -- The user could have clicked the checkbox before switchover, we only
980− -- detect cases where they flipped the state. This must be triggered after
981− -- the setValue one in order for the events to be in the correct order.
982− liftJSM (Input.getChecked domInputElement) >>= \realChecked -> when (realChecked /= switchoverChecked) $
983− liftIO $ triggerCheckedChangedByUI realChecked
984 _ <- liftJSM $ domInputElement `on` Events.click $ do
953 _ <- liftJSM $ domInputElement `on` Events.click $ do
985 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
954 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
986 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
955 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
@@ -993,7 +962,7 @@ inputElementInternal cfg = getHydrationMode >>= \case
993 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
962 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
994 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
963 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
995 return ()
964 return ()
996− checked' <- holdDyn c0 $ leftmost
965+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
997 [ checkedChangedBySetChecked
966 [ checkedChangedBySetChecked
998 , checkedChangedByUI
967 , checkedChangedByUI
999 ]
968 ]
@@ -1065,21 +1034,14 @@ textAreaElementInternal cfg = getHydrationMode >>= \case
1065 doc <- askDocument
1034 doc <- askDocument
1066 -- Expected initial value from config
1035 -- Expected initial value from config
1067 let v0 = _textAreaElementConfig_initialValue cfg
1036 let v0 = _textAreaElementConfig_initialValue cfg
1068− valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)
1037+ addHydrationStep $ do
1069− addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do
1070− switchoverValue <- sample switchoverValue'
1071 domElement <- liftIO $ readIORef domElementRef
1038 domElement <- liftIO $ readIORef domElementRef
1072 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1039 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1073 getValue = TextArea.getValue domTextAreaElement
1040 getValue = TextArea.getValue domTextAreaElement
1074− -- When the value has been updated by setValue before switchover, we must
1041+ -- The browser might have messed with the value, or the user could have
1075− -- send an update here to remain in sync. This is because the later
1042+ -- altered it before activation, so we set it if it isn't what we expect
1076− -- requestDomAction based on the setValue event will not capture events
1043+ liftJSM getValue >>= \v0' -> do
1077− -- happening before postBuild, because this code runs after switchover.
1078− when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
1079− -- The user could have altered the value before switchover. This must be
1080− -- triggered after the setValue one in order for the events to be in the
1081− -- correct order.
1082− liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
1044+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1083 -- Watch for user interaction and trigger event accordingly
1045 -- Watch for user interaction and trigger event accordingly
1084 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1046 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1085 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
1047 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
@@ -1876,14 +1838,14 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
1876 getHydrationMode >>= \case
1838 getHydrationMode >>= \case
1877 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1839 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1878 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1840 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1879− phs <- sequenceA $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1841+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1880 liftIO $ writeIORef placeholders $! phs
1842 liftIO $ writeIORef placeholders $! phs
1881 insertAfterPreviousNode lastPlaceholder
1843 insertAfterPreviousNode lastPlaceholder
1882 HydrationMode_Immediate -> do
1844 HydrationMode_Immediate -> do
1883 let activate i = do
1845 let activate i = do
1884 append $ toNode $ _traverseChildImmediate_fragment i
1846 append $ toNode $ _traverseChildImmediate_fragment i
1885 pure $ _traverseChildImmediate_placeholder i
1847 pure $ _traverseChildImmediate_placeholder i
1886− phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1848+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1887 liftIO $ writeIORef placeholders $! phs
1849 liftIO $ writeIORef placeholders $! phs
1888 append $ toNode lastPlaceholder
1850 append $ toNode lastPlaceholder
1889 requestDomAction_ $ ffor children' $ \p -> do
1851 requestDomAction_ $ ffor children' $ \p -> do
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+10−35
@@ -37,7 +37,6 @@ import Data.IntMap (IntMap)
37import qualified Data.IntMap as IntMap
37import qualified Data.IntMap as IntMap
38import qualified Data.Map as Map
38import qualified Data.Map as Map
39import Data.Map.Misc (applyMap)
39import Data.Map.Misc (applyMap)
40−import Data.Maybe (fromMaybe)
41import Data.Monoid ((<>))
40import Data.Monoid ((<>))
42import qualified Data.Set as Set
41import qualified Data.Set as Set
43import Data.Text (Text)
42import Data.Text (Text)
@@ -274,7 +273,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
274 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
273 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
275 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
274 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
276 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
275 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
277− (modify . (:)) . (\c -> "<!--" <> c <> "-->") =<< case mSetContents of
276+ modify . (:) =<< (\c -> "<!--" <> c <> "-->") <$> case mSetContents of
278 Nothing -> return (pure (escape initialContents))
277 Nothing -> return (pure (escape initialContents))
279 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
278 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
280 return $ CommentNode ()
279 return $ CommentNode ()
@@ -312,32 +311,13 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
312 return (e, result)
311 return (e, result)
313 {-# INLINABLE inputElement #-}
312 {-# INLINABLE inputElement #-}
314 inputElement cfg = do
313 inputElement cfg = do
315− -- Tweak the config to update the "value" and "checked" attributes appropriately.
316− -- TODO: warn upon overwriting values.
317− let setInitialValue = Map.insert "value" (_inputElementConfig_initialValue cfg)
318− setUpdatedValue updatedAttrs = case _inputElementConfig_setValue cfg of
319− Nothing -> updatedAttrs
320− Just e -> (Map.singleton "value" . Just <$> e) <> updatedAttrs
321− setInitialChecked = case _inputElementConfig_initialChecked cfg of
322− True -> Map.insert "checked" "checked"
323− False -> id
324− setUpdatedChecked updatedAttrs = case _inputElementConfig_setChecked cfg of
325− Nothing -> updatedAttrs
326− Just e -> (Map.singleton "checked" (Just "checked") <$ e) <> updatedAttrs
327− adjustedConfig = _inputElementConfig_elementConfig cfg
328− & elementConfig_initialAttributes %~ setInitialValue . setInitialChecked
329− & elementConfig_modifyAttributes %~ setUpdatedValue . setUpdatedChecked
330− (e, _result) <- element "input" adjustedConfig $ return ()
314+ (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
331− v <- case _inputElementConfig_setValue cfg of
332− Nothing -> pure $ constDyn (cfg ^. inputElementConfig_initialValue)
315+ let v0 = constDyn $ cfg ^. inputElementConfig_initialValue
333− Just ev -> holdDyn (cfg ^. inputElementConfig_initialValue) ev
316+ let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked
334− c <- case _inputElementConfig_setChecked cfg of
335− Nothing -> pure $ constDyn $ _inputElementConfig_initialChecked cfg
336− Just ev -> holdDyn (_inputElementConfig_initialChecked cfg) ev
337 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
317 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
338 return $ InputElement
318 return $ InputElement
339− { _inputElement_value = v
319+ { _inputElement_value = v0
340− , _inputElement_checked = c
320+ , _inputElement_checked = c0
341 , _inputElement_checkedChange = never
321 , _inputElement_checkedChange = never
342 , _inputElement_input = never
322 , _inputElement_input = never
343 , _inputElement_hasFocus = hasFocus
323 , _inputElement_hasFocus = hasFocus
@@ -347,17 +327,12 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
347 }
327 }
348 {-# INLINABLE textAreaElement #-}
328 {-# INLINABLE textAreaElement #-}
349 textAreaElement cfg = do
329 textAreaElement cfg = do
330+ --TODO: Support setValue event
350− (e, _domElement) <- element "textarea" (_textAreaElementConfig_elementConfig cfg) $ do
331+ (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
351− -- Set the initial value
352− void $ textNode $ def
353− & textNodeConfig_initialContents .~ _textAreaElementConfig_initialValue cfg
354− & textNodeConfig_setContents .~ fromMaybe never (_textAreaElementConfig_setValue cfg)
355− v <- case _textAreaElementConfig_setValue cfg of
356− Nothing -> pure $ constDyn (cfg ^. textAreaElementConfig_initialValue)
357− Just ev -> holdDyn (cfg ^. textAreaElementConfig_initialValue) ev
332+ let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
358 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
333 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
359 return $ TextAreaElement
334 return $ TextAreaElement
360− { _textAreaElement_value = v
335+ { _textAreaElement_value = v0
361 , _textAreaElement_input = never
336 , _textAreaElement_input = never
362 , _textAreaElement_hasFocus = hasFocus
337 , _textAreaElement_hasFocus = hasFocus
363 , _textAreaElement_element = e
338 , _textAreaElement_element = e
reflex-dom-core/src/Reflex/Dom/Main.hs+7−37
@@ -5,6 +5,7 @@
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE NoMonomorphismRestriction #-}
7{-# LANGUAGE NoMonomorphismRestriction #-}
8+{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
@@ -72,14 +73,8 @@ mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverActio
72{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}
73{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}
73-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.
74-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.
74mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
75mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
75−mainHydrationWidgetWithSwitchoverAction' = mainHydrationWidgetWithSwitchoverActionWithFailure' (pure ())
76+mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do
76−
77−
78−{-# INLINABLE mainHydrationWidgetWithSwitchoverActionWithFailure' #-}
79−-- | Warning: `mainHydrationWidgetWithSwitchoverActionWithFaiilure'` is provided only as performance tweak. It is expected to disappear in future releases.
80−mainHydrationWidgetWithSwitchoverActionWithFailure' :: IO () -> JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
81−mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchoverAction head' body = do
82− runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction $ \appendHead appendBody -> do
77+ runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do
83 appendHead head'
78 appendHead head'
84 appendBody body
79 appendBody body
85
80
@@ -94,21 +89,7 @@ attachHydrationWidget
94 -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
89 -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
95 )
90 )
96 -> IO (a, FireCommand DomTimeline DomHost)
91 -> IO (a, FireCommand DomTimeline DomHost)
97−attachHydrationWidget = attachHydrationWidgetWithFailure (pure ())
98−
99−{-# INLINABLE attachHydrationWidgetWithFailure #-}
100−attachHydrationWidgetWithFailure
101− :: IO ()
102− -> JSM ()
103− -> JSContextSingleton ()
104− -> ( Event DomTimeline ()
105− -> IORef HydrationMode
106− -> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])
107− -> EventChannel
108− -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
109− )
110− -> IO (a, FireCommand DomTimeline DomHost)
111−attachHydrationWidgetWithFailure onFailure switchoverAction jsSing w = do
92+attachHydrationWidget switchoverAction jsSing w = do
112 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
93 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
113 rootNodesRef <- liftIO $ newIORef []
94 rootNodesRef <- liftIO $ newIORef []
114 events <- newChan
95 events <- newChan
@@ -124,7 +105,7 @@ attachHydrationWidgetWithFailure onFailure switchoverAction jsSing w = do
124 rootNodes <- liftIO $ readIORef rootNodesRef
105 rootNodes <- liftIO $ readIORef rootNodesRef
125 let delayedAction = do
106 let delayedAction = do
126 for_ (reverse rootNodes) $ \(rootNode, runner) -> do
107 for_ (reverse rootNodes) $ \(rootNode, runner) -> do
127− let hydrate = runHydrationRunnerTWithFailure runner onFailure Nothing rootNode events
108+ let hydrate = runHydrationRunnerT runner Nothing rootNode events
128 void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
109 void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
129 liftIO $ writeIORef hydrationMode HydrationMode_Immediate
110 liftIO $ writeIORef hydrationMode HydrationMode_Immediate
130 runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing
111 runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing
@@ -145,22 +126,11 @@ runHydrationWidgetWithHeadAndBody
145 -> FloatingWidget () ()
126 -> FloatingWidget () ()
146 )
127 )
147 -> JSM ()
128 -> JSM ()
148−runHydrationWidgetWithHeadAndBody = runHydrationWidgetWithHeadAndBodyWithFailure (pure ())
149−
150−{-# INLINABLE runHydrationWidgetWithHeadAndBodyWithFailure #-}
151−runHydrationWidgetWithHeadAndBodyWithFailure
152− :: IO ()
153− -> JSM ()
154− -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head" --TODO: test invoking this more than once
155− -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body" --TODO: test invoking this more than once
156− -> FloatingWidget () ()
157− )
158− -> JSM ()
159−runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
129+runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
160 globalDoc <- currentDocumentUnchecked
130 globalDoc <- currentDocumentUnchecked
161 headElement <- getHeadUnchecked globalDoc
131 headElement <- getHeadUnchecked globalDoc
162 bodyElement <- getBodyUnchecked globalDoc
132 bodyElement <- getBodyUnchecked globalDoc
163− (events, fc) <- liftIO . attachHydrationWidgetWithFailure onFailure switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
133+ (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
164 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
134 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
165 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
135 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
166 hydrateDom n w = do
136 hydrateDom n w = do
reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hs+1−1
@@ -117,7 +117,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
117 "overflow" =: "hidden" <>
117 "overflow" =: "hidden" <>
118 "position" =: "relative"
118 "position" =: "relative"
119 mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
119 mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
120− "top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <>
120+ "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
121 "position" =: "absolute" <>
121 "position" =: "absolute" <>
122 "width" =: "100%"
122 "width" =: "100%"
123 findWindow sizeIncrement windowSize startingPosition =
123 findWindow sizeIncrement windowSize startingPosition =
reflex-dom-core/test/hlint.hs+1−1
@@ -1,4 +1,4 @@
1−import Language.Haskell.HLint (hlint)
1+import Language.Haskell.HLint3 (hlint)
2import System.Exit (exitFailure, exitSuccess)
2import System.Exit (exitFailure, exitSuccess)
3
3
4main :: IO ()
4main :: IO ()
reflex-dom-core/test/hydration.hs+39−352
@@ -20,14 +20,6 @@
20
20
21{-# OPTIONS_GHC -fno-warn-orphans #-}
21{-# OPTIONS_GHC -fno-warn-orphans #-}
22
22
23−-- Notice to those working on this test suite:
24−-- It doesn't appear to be possible to use --match to run a particular test, in
25−-- this situation the test may hang before reaching our code. This seems to
26−-- happen when the test is not the first test in the block. As a workaround, you
27−-- can just comment out the other tests. Also, using `xit` will cause the same
28−-- issue. `xit` tests must be the last tests in the session, or the session will
29−-- hang in the following test.
30−
31import Prelude hiding (fail)
23import Prelude hiding (fail)
32import Control.Concurrent
24import Control.Concurrent
33import qualified Control.Concurrent.Async as Async
25import qualified Control.Concurrent.Async as Async
@@ -154,13 +146,13 @@ main = do
154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
146 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
147 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
148 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
149+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
158
150
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
151+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
160tests withDebugging wdConfig caps _selenium = do
152tests withDebugging wdConfig caps _selenium = do
161 let putStrLnDebug :: MonadIO m => Text -> m ()
153 let putStrLnDebug :: MonadIO m => Text -> m ()
162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
154 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
155+ session' = sessionWith wdConfig "" . using (map (,"") caps)
164 runWD m = runWDOptions (WdOptions False) $ do
156 runWD m = runWDOptions (WdOptions False) $ do
165 putStrLnDebug "before"
157 putStrLnDebug "before"
166 r <- m
158 r <- m
@@ -169,10 +161,10 @@ tests withDebugging wdConfig caps _selenium = do
169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
161 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170 testWidgetStatic = testWidgetStaticDebug withDebugging
162 testWidgetStatic = testWidgetStaticDebug withDebugging
171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
163 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
164+ testWidget = testWidgetDebug withDebugging
173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
165 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
174− testWidget' = testWidgetDebug' True withDebugging
166+ testWidget' = testWidgetDebug' withDebugging
175− session' "text" $ do
167+ describe "text" $ session' $ do
176 it "works" $ runWD $ do
168 it "works" $ runWD $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
169 testWidgetStatic (checkBodyText "hello world") $ do
178 text "hello world"
170 text "hello world"
@@ -233,7 +225,7 @@ tests withDebugging wdConfig caps _selenium = do
233 click <- button ""
225 click <- button ""
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
226 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
235
227
236− session' "element" $ do
228+ describe "element" $ session' $ do
237 it "works with domEvent Click" $ runWD $ do
229 it "works with domEvent Click" $ runWD $ do
238 clickedRef <- liftIO $ newRef False
230 clickedRef <- liftIO $ newRef False
239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
231 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -297,78 +289,21 @@ tests withDebugging wdConfig caps _selenium = do
297 let click = domEvent Click e
289 let click = domEvent Click e
298 return ()
290 return ()
299
291
300− session' "inputElement" $ do
292+ describe "inputElement" $ do
301− describe "static renderer" $ do
293+ describe "hydration" $ session' $ do
302− it "sets value attribute" $ runWD $ do
303− let checkStatic = do
304− e <- findElemWithRetry $ WD.ByTag "input"
305− WD.attr e "value" `shouldBeWithRetryM` Just "test"
306− pure e
307− checkHydrated e = do
308− WD.attr e "value" `shouldBeWithRetryM` Just "test"
309− testWidget' checkStatic checkHydrated $ void $ inputElement $ def
310− & inputElementConfig_initialValue .~ "test"
311− it "updates value attribute at postBuild" $ runWD $ do
312− let checkStatic = do
313− e <- findElemWithRetry $ WD.ByTag "input"
314− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
315− pure e
316− checkHydrated e = do
317− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318− testWidget' checkStatic checkHydrated $ do
319− pb <- getPostBuild
320− _ <- inputElement $ def
321− & inputElementConfig_initialValue .~ "test"
322− & inputElementConfig_setValue .~ ("test-updated" <$ pb)
323− pure ()
324− it "sets checked attr appropriately" $ runWD $ do
325− setCheckedChan <- liftIO newChan
326− let checkStatic = do
327− e <- findElemWithRetry $ WD.ByTag "input"
328− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
329− pure e
330− checkValue e = do
331− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
332− WD.moveToCenter e
333− WD.click e -- Click to uncheck
334− WD.attr e "checked" `shouldBeWithRetryM` Nothing
335− liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
336− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
337− testWidget' checkStatic checkValue $ do
338− setChecked <- triggerEventWithChan setCheckedChan
339− _ <- inputElement $ def
340− & initialAttributes .~ "type" =: "checkbox"
341− & inputElementConfig_initialChecked .~ True
342− & inputElementConfig_setChecked .~ setChecked
343− pure ()
344− it "sets checked attr appropriately at postbuild" $ runWD $ do
345− let checkStatic = do
346− e <- findElemWithRetry $ WD.ByTag "input"
347− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
348− pure e
349− checkValue e = do
350− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351− testWidget' checkStatic checkValue $ do
352− pb <- getPostBuild
353− _ <- inputElement $ def
354− & initialAttributes .~ "type" =: "checkbox"
355− & inputElementConfig_initialChecked .~ False
356− & inputElementConfig_setChecked .~ (True <$ pb)
357− pure ()
358− describe "hydration" $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
294 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
295+ inputRef <- newRef ("" :: Text)
361 testWidget'
296 testWidget'
362 (do
297 (do
363 e <- findElemWithRetry $ WD.ByTag "input"
298 e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
299+ WD.sendKeys "hello world" e
365 pure e)
300 pure e)
366 (\e -> do
301 (\e -> do
367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
302 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368 WD.click =<< findElemWithRetry (WD.ByTag "button")
303 WD.click =<< findElemWithRetry (WD.ByTag "button")
369 readRef inputRef `shouldBeWithRetryM` "hello world"
304 readRef inputRef `shouldBeWithRetryM` "hello world"
370 ) $ do
305 ) $ do
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
306+ e <- inputElement def
372 click <- button "save"
307 click <- button "save"
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
308 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374 it "captures user input after switchover" $ runWD $ do
309 it "captures user input after switchover" $ runWD $ do
@@ -425,49 +360,24 @@ tests withDebugging wdConfig caps _selenium = do
425 checkedByUIRef <- newRef False
360 checkedByUIRef <- newRef False
426 checkedRef <- newRef False
361 checkedRef <- newRef False
427 setCheckedChan <- liftIO newChan
362 setCheckedChan <- liftIO newChan
428− let checkStatic = do
429− e <- findElemWithRetry $ WD.ByTag "input"
430− WD.attr e "checked" `shouldBeWithRetryM` Nothing
431− pure e
432− checkValue e = do
363+ let checkValue = do
433 readRef checkedByUIRef `shouldBeWithRetryM` False
364 readRef checkedByUIRef `shouldBeWithRetryM` False
434 readRef checkedRef `shouldBeWithRetryM` False
365 readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
366+ e <- findElemWithRetry $ WD.ByTag "input"
436 WD.moveToCenter e
367 WD.moveToCenter e
437 WD.click e
368 WD.click e
438 readRef checkedByUIRef `shouldBeWithRetryM` True
369 readRef checkedByUIRef `shouldBeWithRetryM` True
439 readRef checkedRef `shouldBeWithRetryM` True
370 readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
441 liftIO $ writeChan setCheckedChan False
371 liftIO $ writeChan setCheckedChan False
442 readRef checkedByUIRef `shouldBeWithRetryM` True
372 readRef checkedByUIRef `shouldBeWithRetryM` True
443 readRef checkedRef `shouldBeWithRetryM` False
373 readRef checkedRef `shouldBeWithRetryM` False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
374+ testWidget (pure ()) checkValue $ do
446 setChecked <- triggerEventWithChan setCheckedChan
375 setChecked <- triggerEventWithChan setCheckedChan
447 e <- inputElement $ def
376 e <- inputElement $ def
448 & initialAttributes .~ "type" =: "checkbox"
377 & initialAttributes .~ "type" =: "checkbox"
449 & inputElementConfig_setChecked .~ setChecked
378 & inputElementConfig_setChecked .~ setChecked
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
379 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
380 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452− it "respects user updates to checked which happen before hydration" $ runWD $ do
453− checkedByUIRef <- newRef False
454− checkedRef <- newRef False
455− let checkStatic = do
456− e <- findElemWithRetry $ WD.ByTag "input"
457− WD.attr e "checked" `shouldBeWithRetryM` Nothing
458− WD.moveToCenter e
459− WD.click e
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
461− pure e
462− checkValue e = do
463− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464− readRef checkedByUIRef `shouldBeWithRetryM` True
465− readRef checkedRef `shouldBeWithRetryM` True
466− testWidget' checkStatic checkValue $ do
467− e <- inputElement $ def
468− & initialAttributes .~ "type" =: "checkbox"
469− performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470− performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
471 it "captures file uploads" $ runWD $ do
381 it "captures file uploads" $ runWD $ do
472 filesRef :: IORef [Text] <- newRef []
382 filesRef :: IORef [Text] <- newRef []
473 let uploadFile = do
383 let uploadFile = do
@@ -483,117 +393,8 @@ tests withDebugging wdConfig caps _selenium = do
483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
393 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484 names <- liftJSM $ traverse File.getName fs
394 names <- liftJSM $ traverse File.getName fs
485 liftIO $ writeRef filesRef names
395 liftIO $ writeRef filesRef names
486− it "fires _input event if the user altered the value before hydration" $ runWD $ do
396+
487− input <- newRef ("" :: Text)
488− update <- newRef ("" :: Text)
489− let checkStatic = do
490− e <- findElemWithRetry $ WD.ByTag "input"
491− WD.attr e "value" `shouldBeWithRetryM` Just ""
492− WD.sendKeys "test" e
493− WD.attr e "value" `shouldBeWithRetryM` Just "test"
494− pure e
495− checkHydrated e = do
496− WD.attr e "value" `shouldBeWithRetryM` Just "test"
497− readRef input `shouldBeWithRetryM` "test"
498− readRef update `shouldBeWithRetryM` "test"
499− testWidget' checkStatic checkHydrated $ do
500− e <- inputElement def
501− performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
502− performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
503− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
504− input <- newRef (Nothing :: Maybe Text)
505− let checkStatic = do
506− e <- findElemWithRetry $ WD.ByTag "input"
507− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
508− pure e
509− checkHydrated e = do
510− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511− readRef input `shouldBeWithRetryM` Nothing
512− testWidget' checkStatic checkHydrated $ do
513− pb <- getPostBuild
514− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
515− performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
516− it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
517− let checkBoth = do
518− input <- findElemWithRetry $ WD.ByTag "input"
519− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
520− p <- findElemWithRetry (WD.ByTag "p")
521− shouldContainText "pb" p
522− testWidget checkBoth checkBoth $ do
523− pb <- getPostBuild
524− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
525− el "p" $ dynText $ _inputElement_value e
526− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
527− let checkStatic = do
528− input <- findElemWithRetry $ WD.ByTag "input"
529− h2_value <- findElemWithRetry (WD.ByTag "h2")
530− h3_input <- findElemWithRetry (WD.ByTag "h3")
531− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
532− shouldContainText "pb" h2_value
533− shouldContainText "" h3_input
534− WD.sendKeys "abc" input
535− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
536− shouldContainText "pb" h2_value
537− shouldContainText "" h3_input
538− pure (input, h2_value, h3_input)
539− checkHydrated (input, h2_value, h3_input) = do
540− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
541− shouldContainText "pbabc" h3_input
542− shouldContainText "pbabc pb" h2_value
543− pure ()
544− testWidget' checkStatic checkHydrated $ do
545− pb <- getPostBuild
546− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
547− el "h1" $ dynText $ _inputElement_value e
548− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
549− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
550− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
551− let checkStatic = do
552− input <- findElemWithRetry $ WD.ByTag "input"
553− p <- findElemWithRetry (WD.ByTag "p")
554− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
555− shouldContainText "pb" p
556− WD.sendKeys "abc" input
557− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
558− shouldContainText "pb" p -- It won't be updated yet
559− pure (input, p)
560− checkHydrated (input, p) = do
561− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562− shouldContainText "pbabc" p
563− pure ()
564− testWidget' checkStatic checkHydrated $ do
565− pb <- getPostBuild
566− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
567− el "p" $ dynText $ _inputElement_value e
568− it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
569− valRef <- newRef ([] :: [Text])
570− inputRef <- newRef ([] :: [Text])
571− let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
572− checkStatic = do
573− input <- findElemWithRetry $ WD.ByTag "input"
574− p <- findElemWithRetry (WD.ByTag "p")
575− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
576− shouldContainText "pb" p
577− WD.sendKeys "abc" input
578− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
579− shouldContainText "pb" p -- It won't be updated yet
580− readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
581− readRef valRef `shouldBeWithRetryM` ["pb"]
582− pure (input, p)
583− checkHydrated (input, p) = do
584− readRef inputRef `shouldBeWithRetryM` ["pbabc"]
585− readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
586− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
587− shouldContainText "pbabc" p
588− pure ()
589− testWidget' checkStatic checkHydrated $ do
590− liftIO $ writeRef valRef []
591− pb <- getPostBuild
592− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
593− el "p" $ dynText $ _inputElement_value e
594− performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
595− performEvent_ $ consRef inputRef <$> _inputElement_input e
596− describe "hydration/immediate" $ do
397+ describe "hydration/immediate" $ session' $ do
597 it "captures user input after switchover" $ runWD $ do
398 it "captures user input after switchover" $ runWD $ do
598 inputRef :: IORef Text <- newRef ""
399 inputRef :: IORef Text <- newRef ""
599 let checkValue = do
400 let checkValue = do
@@ -673,31 +474,8 @@ tests withDebugging wdConfig caps _selenium = do
673 names <- liftJSM $ traverse File.getName fs
474 names <- liftJSM $ traverse File.getName fs
674 liftIO $ writeRef filesRef names
475 liftIO $ writeRef filesRef names
675
476
676− session' "textAreaElement" $ do
477+ describe "textAreaElement" $ do
677− describe "static renderer" $ do
678− it "sets value attribute" $ runWD $ do
679− let checkStatic = do
680− e <- findElemWithRetry $ WD.ByTag "textarea"
681− WD.attr e "value" `shouldBeWithRetryM` Just "test"
682− pure e
683− checkHydrated e = do
684− WD.attr e "value" `shouldBeWithRetryM` Just "test"
685− testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
686− & textAreaElementConfig_initialValue .~ "test"
687− it "updates value attribute at postBuild" $ runWD $ do
688− let checkStatic = do
689− e <- findElemWithRetry $ WD.ByTag "textarea"
690− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
691− pure e
692− checkHydrated e = do
693− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694− testWidget' checkStatic checkHydrated $ do
695− pb <- getPostBuild
696− _ <- textAreaElement $ def
697− & textAreaElementConfig_initialValue .~ "test"
698− & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
699− pure ()
700− describe "hydration" $ do
478+ describe "hydration" $ session' $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
479 it "doesn't wipe user input when switching over" $ runWD $ do
702 inputRef <- newRef ("" :: Text)
480 inputRef <- newRef ("" :: Text)
703 testWidget'
481 testWidget'
@@ -763,90 +541,8 @@ tests withDebugging wdConfig caps _selenium = do
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
541 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
542 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
543 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
766− it "fires _input event if the user altered the value before hydration" $ runWD $ do
767− textarea <- newRef ("" :: Text)
768− update <- newRef ("" :: Text)
769− let checkStatic = do
770− e <- findElemWithRetry $ WD.ByTag "textarea"
771− WD.attr e "value" `shouldBeWithRetryM` Just ""
772− WD.sendKeys "test" e
773− WD.attr e "value" `shouldBeWithRetryM` Just "test"
774− pure e
775− checkHydrated e = do
776− WD.attr e "value" `shouldBeWithRetryM` Just "test"
777− readRef textarea `shouldBeWithRetryM` "test"
778− readRef update `shouldBeWithRetryM` "test"
779− testWidget' checkStatic checkHydrated $ do
780− e <- textAreaElement def
781− performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
782− performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
783− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
784− textarea <- newRef (Nothing :: Maybe Text)
785− let checkStatic = do
786− e <- findElemWithRetry $ WD.ByTag "textarea"
787− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
788− pure e
789− checkHydrated e = do
790− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791− readRef textarea `shouldBeWithRetryM` Nothing
792− testWidget' checkStatic checkHydrated $ do
793− pb <- getPostBuild
794− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
795− performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
796− it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
797− let checkBoth = do
798− textarea <- findElemWithRetry $ WD.ByTag "textarea"
799− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
800− p <- findElemWithRetry (WD.ByTag "p")
801− shouldContainText "pb" p
802− testWidget checkBoth checkBoth $ do
803− pb <- getPostBuild
804− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
805− el "p" $ dynText $ _textAreaElement_value e
806− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
807− let checkStatic = do
808− textarea <- findElemWithRetry $ WD.ByTag "textarea"
809− h2_value <- findElemWithRetry (WD.ByTag "h2")
810− h3_input <- findElemWithRetry (WD.ByTag "h3")
811− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
812− shouldContainText "pb" h2_value
813− shouldContainText "" h3_input
814− WD.sendKeys "abc" textarea
815− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
816− shouldContainText "pb" h2_value
817− shouldContainText "" h3_input
818− pure (textarea, h2_value, h3_input)
819− checkHydrated (textarea, h2_value, h3_input) = do
820− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
821− shouldContainText "pbabc" h3_input
822− shouldContainText "pbabc pb" h2_value
823− pure ()
824− testWidget' checkStatic checkHydrated $ do
825− pb <- getPostBuild
826− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
827− el "h1" $ dynText $ _textAreaElement_value e
828− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
829− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
830− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
831− let checkStatic = do
832− textarea <- findElemWithRetry $ WD.ByTag "textarea"
833− p <- findElemWithRetry (WD.ByTag "p")
834− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
835− shouldContainText "pb" p
836− WD.sendKeys "abc" textarea
837− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
838− shouldContainText "pb" p -- It won't be updated yet
839− pure (textarea, p)
840− checkHydrated (textarea, p) = do
841− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842− shouldContainText "pbabc" p
843− pure ()
844− testWidget' checkStatic checkHydrated $ do
845− pb <- getPostBuild
846− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847− el "p" $ dynText $ _textAreaElement_value e
848
544
849− describe "hydration/immediate" $ do
545+ describe "hydration/immediate" $ session' $ do
850 it "captures user input after switchover" $ runWD $ do
546 it "captures user input after switchover" $ runWD $ do
851 inputRef :: IORef Text <- newRef ""
547 inputRef :: IORef Text <- newRef ""
852 let checkValue = do
548 let checkValue = do
@@ -888,13 +584,13 @@ tests withDebugging wdConfig caps _selenium = do
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
584 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
585 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
890
586
891− session' "selectElement" $ do
587+ describe "selectElement" $ do
892 let options :: DomBuilder t m => m ()
588 let options :: DomBuilder t m => m ()
893 options = do
589 options = do
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
590 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
591 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
592 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
593+ describe "hydration" $ session' $ do
898 it "sets initial value correctly" $ runWD $ do
594 it "sets initial value correctly" $ runWD $ do
899 inputRef <- newRef ("" :: Text)
595 inputRef <- newRef ("" :: Text)
900 let setup = do
596 let setup = do
@@ -968,7 +664,7 @@ tests withDebugging wdConfig caps _selenium = do
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
664 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
665 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
970
666
971− describe "hydration/immediate" $ do
667+ describe "hydration/immediate" $ session' $ do
972 it "captures user input after switchover" $ runWD $ do
668 it "captures user input after switchover" $ runWD $ do
973 inputRef :: IORef Text <- newRef ""
669 inputRef :: IORef Text <- newRef ""
974 let checkValue = do
670 let checkValue = do
@@ -1014,7 +710,7 @@ tests withDebugging wdConfig caps _selenium = do
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
710 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
711 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1016
712
1017− session' "prerender" $ do
713+ describe "prerender" $ session' $ do
1018 it "works in simple case" $ runWD $ do
714 it "works in simple case" $ runWD $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
715 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020 prerender_ (text "One") (text "Two")
716 prerender_ (text "One") (text "Two")
@@ -1083,7 +779,7 @@ tests withDebugging wdConfig caps _selenium = do
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
779 prerender_ (pure ()) (liftIO $ trigger "Client")
1084 textNode $ TextNodeConfig "Initial" $ Just e
780 textNode $ TextNodeConfig "Initial" $ Just e
1085
781
1086− session' "namespaces" $ do
782+ describe "namespaces" $ session' $ do
1087 it "dyn can be nested in namespaced widget" $ runWD $ do
783 it "dyn can be nested in namespaced widget" $ runWD $ do
1088 testWidget (pure ()) (checkTextInTag "svg" "one") $ do
784 testWidget (pure ()) (checkTextInTag "svg" "one") $ do
1089 let svgRootCfg = def
785 let svgRootCfg = def
@@ -1092,7 +788,7 @@ tests withDebugging wdConfig caps _selenium = do
1092 void $ element "svg" svgRootCfg $ do
788 void $ element "svg" svgRootCfg $ do
1093 dyn_ $ text "one" <$ pure ()
789 dyn_ $ text "one" <$ pure ()
1094
790
1095− session' "runWithReplace" $ do
791+ describe "runWithReplace" $ session' $ do
1096 it "works" $ runWD $ do
792 it "works" $ runWD $ do
1097 replaceChan :: Chan Text <- liftIO newChan
793 replaceChan :: Chan Text <- liftIO newChan
1098 let setup = findElemWithRetry $ WD.ByTag "div"
794 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -1266,9 +962,7 @@ tests withDebugging wdConfig caps _selenium = do
1266 _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
962 _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
1267 text "|after"
963 text "|after"
1268 void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
964 void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
1269− -- TODO This test actually causes a hydration failure, but it wasn't
1270− -- previously detected, so I've marked it pending
1271− xit "ignores missing ending bracketing comments" $ runWD $ do
965+ it "ignores missing ending bracketing comments" $ runWD $ do
1272 replaceChan :: Chan () <- liftIO newChan
966 replaceChan :: Chan () <- liftIO newChan
1273 let
967 let
1274 preSwitchover = do
968 preSwitchover = do
@@ -1290,7 +984,7 @@ tests withDebugging wdConfig caps _selenium = do
1290 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
984 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1291 text "|after"
985 text "|after"
1292
986
1293− session' "traverseDMapWithKeyWithAdjust" $ do
987+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
988 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
989 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296 elClass "span" "key" $ text $ textKey k
990 elClass "span" "key" $ text $ textKey k
@@ -1393,7 +1087,7 @@ tests withDebugging wdConfig caps _selenium = do
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1087 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1394 liftIO $ dmap `H.shouldBe` keyMap
1088 liftIO $ dmap `H.shouldBe` keyMap
1395
1089
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1090+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1397 let textKeyInt k = "key" <> T.pack (show k)
1091 let textKeyInt k = "key" <> T.pack (show k)
1398 intMap = IntMap.fromList
1092 intMap = IntMap.fromList
1399 [ (1, "one")
1093 [ (1, "one")
@@ -1500,7 +1194,7 @@ tests withDebugging wdConfig caps _selenium = do
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1194 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1501 liftIO $ dmap `H.shouldBe` intMap
1195 liftIO $ dmap `H.shouldBe` intMap
1502
1196
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1197+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1198 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1199 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1506 elClass "span" "key" $ text $ textKey2 k
1200 elClass "span" "key" $ text $ textKey2 k
@@ -1580,8 +1274,8 @@ tests withDebugging wdConfig caps _selenium = do
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1274 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1581 liftIO $ assertEqual "DMap" initMap dmap
1275 liftIO $ assertEqual "DMap" initMap dmap
1582
1276
1583− session' "hydrating invalid HTML" $ do
1277+ describe "hydrating invalid HTML" $ session' $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1278+ it "can hydrate list in paragraph" $ runWD $ do
1585 let preSwitchover = do
1279 let preSwitchover = do
1586 checkBodyText "before\ninner\nafter"
1280 checkBodyText "before\ninner\nafter"
1587 -- Two <p> tags should be present
1281 -- Two <p> tags should be present
@@ -1598,8 +1292,7 @@ tests withDebugging wdConfig caps _selenium = do
1598 shouldContainText "before\ninner\nafter" p1
1292 shouldContainText "before\ninner\nafter" p1
1599 elementShouldBeRemoved ol
1293 elementShouldBeRemoved ol
1600 elementShouldBeRemoved p2
1294 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1295+ testWidget' preSwitchover check $ do
1603 -- This is deliberately invalid HTML, the browser will interpret it as
1296 -- This is deliberately invalid HTML, the browser will interpret it as
1604 -- <p>before</p><ol>inner</ol>after<p></p>
1297 -- <p>before</p><ol>inner</ol>after<p></p>
1605 el "p" $ do
1298 el "p" $ do
@@ -1610,7 +1303,7 @@ tests withDebugging wdConfig caps _selenium = do
1610 -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1303 -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1611 -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1304 -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1612 -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1305 -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1613− session' "dropdown" $ do
1306+ describe "dropdown" $ session' $ do
1614 let doTest expectedOpts (initialValue :: Text) = do
1307 let doTest expectedOpts (initialValue :: Text) = do
1615 let doCheck = do
1308 let doCheck = do
1616 es <- findElemsWithRetry $ WD.ByTag "option"
1309 es <- findElemsWithRetry $ WD.ByTag "option"
@@ -1725,12 +1418,11 @@ testWidgetStaticDebug
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1418 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1726 -- ^ Widget we are testing
1419 -- ^ Widget we are testing
1727 -> WD b
1420 -> WD b
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1421+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1729
1422
1730-- | TODO: do something about JSExceptions not causing tests to fail
1423-- | TODO: do something about JSExceptions not causing tests to fail
1731testWidgetDebug
1424testWidgetDebug
1732 :: Bool
1425 :: Bool
1733− -> Bool
1734 -> WD ()
1426 -> WD ()
1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1427 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1736 -> WD b
1428 -> WD b
@@ -1738,16 +1430,12 @@ testWidgetDebug
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1430 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1739 -- ^ Widget we are testing
1431 -- ^ Widget we are testing
1740 -> WD b
1432 -> WD b
1741−testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1433+testWidgetDebug withDebugging beforeJS afterSwitchover =
1742− testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1434+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1743−
1744−data HydrationFailedException = HydrationFailedException deriving Show
1745−instance Exception HydrationFailedException
1746
1435
1747-- | TODO: do something about JSExceptions not causing tests to fail
1436-- | TODO: do something about JSExceptions not causing tests to fail
1748testWidgetDebug'
1437testWidgetDebug'
1749 :: Bool
1438 :: Bool
1750− -> Bool
1751 -> WD a
1439 -> WD a
1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1440 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1753 -> (a -> WD b)
1441 -> (a -> WD b)
@@ -1755,7 +1443,7 @@ testWidgetDebug'
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1443 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1756 -- ^ Widget we are testing (contents of body)
1444 -- ^ Widget we are testing (contents of body)
1757 -> WD b
1445 -> WD b
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1446+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1759 let putStrLnDebug :: MonadIO m => Text -> m ()
1447 let putStrLnDebug :: MonadIO m => Text -> m ()
1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1448 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1761 staticApp = do
1449 staticApp = do
@@ -1767,7 +1455,6 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1767 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1455 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1768 putStrLnDebug "rendered static"
1456 putStrLnDebug "rendered static"
1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1457 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1458 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1772 let entryPoint = do
1459 let entryPoint = do
1773 putStrLnDebug "taking waitBeforeJS"
1460 putStrLnDebug "taking waitBeforeJS"
@@ -1779,7 +1466,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1779 liftIO $ putMVar waitUntilSwitchover ()
1466 liftIO $ putMVar waitUntilSwitchover ()
1780 putStrLnDebug "put waitUntilSwitchover"
1467 putStrLnDebug "put waitUntilSwitchover"
1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1468 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1469+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1470 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1784 syncPoint
1471 syncPoint
1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1472 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
reflex-dom-test-selenium/CHANGELOG.mddeleted−5
@@ -1,5 +0,0 @@
1−# Revision history for reflex-dom-core-selenium
2−
3−## 0.1.0.0 -- YYYY-mm-dd
4−
5−* First version. Released on an unsuspecting world.
reflex-dom-test-selenium/LICENSEdeleted−12
@@ -1,12 +0,0 @@
1−Copyright (c) 2020, Obsidian Systems LLC
2−All rights reserved.
3−
4−Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5−
6−1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7−
8−2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9−
10−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11−
12−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
reflex-dom-test-selenium/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
reflex-dom-test-selenium/add-overrides.nixdeleted−20
@@ -1,20 +0,0 @@
1−{ nixpkgs }: testPackage:
2− nixpkgs.haskell.lib.overrideCabal testPackage
3− (drv: {
4−
5− # The headless browser run as part of the tests will exit without this
6− preBuild = ''
7− export HOME="$PWD"
8− '';
9−
10− testSystemDepends = with nixpkgs; (drv.testSystemDepends or []) ++ [
11− selenium-server-standalone which
12− chromium
13− nixpkgs.iproute
14− ];
15−
16− # The headless browser run as part of gc tests would hang/crash without this
17− preCheck = ''
18− export FONTCONFIG_PATH=${nixpkgs.fontconfig.out}/etc/fonts
19− '';
20− })
reflex-dom-test-selenium/reflex-dom-test-selenium.cabaldeleted−41
@@ -1,41 +0,0 @@
1−cabal-version: 1.24
2−Name: reflex-dom-test-selenium
3−Version: 0.0.0.1
4−Synopsis: Testing framework for selenium tests
5−Description:
6−License: BSD3
7−License-file: LICENSE
8−Author: Ryan Trinkle
9−Maintainer: ryan.trinkle@gmail.com
10−Stability: Experimental
11−Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
12−Build-type: Simple
13−
14−library
15− hs-source-dirs: src
16− build-depends:
17− async,
18− base >= 4.7 && < 4.15,
19− bytestring == 0.10.*,
20− chrome-test-utils,
21− exceptions,
22− hspec-core,
23− hspec-webdriver >= 1.2.1,
24− http-types,
25− jsaddle >= 0.9.0.0 && < 0.10,
26− jsaddle-warp,
27− network,
28− process,
29− reflex-dom-core,
30− silently,
31− text == 1.2.*,
32− wai,
33− warp,
34− webdriver,
35− websockets
36−
37− exposed-modules:
38− Reflex.Dom.Test.Selenium
39−
40− default-language: Haskell98
41− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
reflex-dom-test-selenium/src/Reflex/Dom/Test/Selenium.hsdeleted−249
@@ -1,249 +0,0 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TemplateHaskell #-}
9−
10−{-# OPTIONS_GHC -fno-warn-orphans #-}
11−
12−-- | Utilities for testing reflex-dom widgets with Selenium.
13−--
14−-- Any uses of the 'testWidget' functions will start a jsaddle warp server and
15−-- serve the given widget in an otherwise empty page. Webdriver commands can run
16−-- on the statically rendered page, and on the hydrated page.
17−module Reflex.Dom.Test.Selenium
18− ( TestWidget
19− , TestWidgetConfig (..)
20− , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
21− , withSeleniumSpec
22− , embedSpec
23− , SeleniumSetupConfig (..)
24− ) where
25−
26−import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
27−import Control.Exception (throwIO)
28−import Control.Monad (when)
29−import Control.Monad.Catch (MonadMask, handle)
30−import Control.Monad.Fix (MonadFix)
31−import Control.Monad.IO.Class (MonadIO, liftIO)
32−import Data.Text (Text)
33−import Language.Javascript.JSaddle
34−import Language.Javascript.JSaddle.Warp
35−import Network.HTTP.Types (status200)
36−import Network.Socket (PortNumber)
37−import Network.Wai (responseLBS)
38−import Network.WebSockets (defaultConnectionOptions)
39−import Reflex.Dom.Core
40−import System.IO (stderr)
41−import System.IO.Silently (hSilence)
42−import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
43−import Test.Hspec.WebDriver (Spec, SpecWith, WdTestSession, sessionWith, using)
44−import Test.Util.ChromeFlags
45−import Test.Util.UnshareNetwork
46−import Test.WebDriver (WD)
47−
48−import qualified Control.Concurrent.Async as Async
49−import qualified Data.ByteString.Lazy as LBS
50−import qualified Data.Text as T
51−import qualified Data.Text.Encoding as TE
52−import qualified Network.Wai.Handler.Warp as Warp
53−import qualified Test.Hspec.Core.Spec as Hspec
54−import qualified Test.WebDriver as WD
55−import qualified Test.WebDriver.Capabilities as WD
56−
57−deriving instance MonadMask WD
58−
59−data SeleniumSetupConfig = SeleniumSetupConfig
60− { _seleniumSetupConfig_chromiumPath :: FilePath
61− -- ^ Path to the chromium executable
62− , _seleniumSetupConfig_headless :: Bool
63− -- ^ True means that the browser is invoked in headless mode, False means that
64− -- the user can see the interaction happening on the browser (useful for debugging).
65− , _seleniumSetupConfig_seleniumPort :: PortNumber
66− -- ^ The port number used by selenium
67− }
68−
69−-- | Setup a selenium server and use it to run some hspec tests.
70−--
71−-- withSeleniumSpec config $ \runSession -> hspec $ do
72−-- describe "tests using webdriver session" $ runSession $ do
73−-- webdriver tests here
74−withSeleniumSpec :: SeleniumSetupConfig -> ((forall multi. SpecWith (WdTestSession multi) -> Spec) -> IO a) -> IO a
75−withSeleniumSpec config runSpec = do
76− liftIO $ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
77− withSandboxedChromeFlags (_seleniumSetupConfig_headless config) $ \chromeFlags -> do
78− withSeleniumServer (_seleniumSetupConfig_seleniumPort config) $ do
79− let browserPath = T.strip $ T.pack $ _seleniumSetupConfig_chromiumPath config
80− when (T.null browserPath) $ fail "No browser found"
81− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }
82− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
83− runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]
84−
85−startSeleniumServer :: PortNumber -> IO (IO ())
86−startSeleniumServer port = do
87− (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
88− { std_in = NoStream
89− , std_out = NoStream
90− , std_err = NoStream
91− }
92− return $ terminateProcess ph
93−
94−withSeleniumServer :: PortNumber -> IO a -> IO a
95−withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do
96− threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
97− f
98−
99−chromeConfig :: Text -> [Text] -> WD.WDConfig
100−chromeConfig fp flags =
101− WD.useBrowser
102− (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags })
103− WD.defaultConfig
104−
105−--------------------------------------------------------------------------------
106−-- Function to test widgets
107−--------------------------------------------------------------------------------
108−
109−-- | The environment in which your widgets can be tested
110−type TestWidget js t m =
111− (DomBuilder t m, MonadHold t m, PostBuild t m
112− , Prerender js t m, PerformEvent t m, TriggerEvent t m
113− , MonadFix m, MonadIO (Performable m), MonadIO m)
114−
115−-- | Configuration of individual tests
116−data TestWidgetConfig = TestWidgetConfig
117− { _testWidgetConfig_debug :: Bool
118− -- ^ If this flag is set to True, during the test we will emit debug messages
119− , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
120− -- ^ We can add widgets here that will be included in the head of the page
121− -- (useful for example to include external js libraries in the tests)
122− , _testWidgetConfig_jsaddlePort :: PortNumber
123− -- ^ Port used by the jsaddle server
124− }
125−
126−-- | Test a widget by running some webdriver commands before and after
127−-- hydration.
128−testWidget
129− :: TestWidgetConfig
130− -> WD a
131− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
132− -> WD b
133− -- ^ Webdriver commands to run after hydration switchover
134− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
135− -- ^ Widget we are testing (contents of body)
136− -> WD b
137−testWidget cfg before after widget = testWidget' cfg before (const after) widget
138−
139−-- | Test a widget by running some webdriver commands before hydration (on the
140−-- statically rendered page).
141−testWidgetStatic
142− :: TestWidgetConfig
143− -> WD a
144− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
145− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
146− -- ^ Widget we are testing (contents of body)
147− -> WD a
148−testWidgetStatic cfg before widget = testWidget' cfg before pure widget
149−
150−-- | Test a widget by running some webdriver commands after hydration.
151−testWidgetHydrated
152− :: TestWidgetConfig
153− -> WD b
154− -- ^ Webdriver commands to run after hydration switchover
155− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
156− -- ^ Widget we are testing (contents of body)
157− -> WD b
158−testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
159−
160−-- | Test a widget by running some webdriver commands before and after
161−-- hydration. Like 'testWidget', but you can use the result of the webdriver
162−-- commands from before hydration in the post hydration test.
163−testWidget'
164− :: TestWidgetConfig
165− -> WD a
166− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
167− -> (a -> WD b)
168− -- ^ Webdriver commands to run after hydration switchover
169− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
170− -- ^ Widget we are testing (contents of body)
171− -> WD b
172−testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do
173− let putStrLnDebug :: MonadIO m => Text -> m ()
174− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
175− staticApp = do
176− el "head" $ headWidget
177− el "body" $ do
178− bodyWidget
179− el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
180− putStrLnDebug "rendering static"
181− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
182− putStrLnDebug "rendered static"
183− waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
184− waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
185− let entryPoint = do
186− putStrLnDebug "taking waitBeforeJS"
187− liftIO $ takeMVar waitBeforeJS
188− let switchOverAction = do
189− putStrLnDebug "switchover syncPoint"
190− syncPoint
191− putStrLnDebug "putting waitUntilSwitchover"
192− liftIO $ putMVar waitUntilSwitchover ()
193− putStrLnDebug "put waitUntilSwitchover"
194− putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
195− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
196− putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
197− syncPoint
198− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
199− putStrLnDebug "sending response"
200− r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
201− putStrLnDebug "sent response"
202− return r
203− waitJSaddle <- liftIO newEmptyMVar
204− let settings = foldr ($) Warp.defaultSettings
205− [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
206− , Warp.setBeforeMainLoop $ do
207− putStrLnDebug "putting waitJSaddle"
208− putMVar waitJSaddle ()
209− putStrLnDebug "put waitJSaddle"
210− ]
211− -- hSilence to get rid of ConnectionClosed logs
212− silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]
213− jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application
214− withAsync' jsaddleWarp $ do
215− putStrLnDebug "taking waitJSaddle"
216− liftIO $ takeMVar waitJSaddle
217− putStrLnDebug "opening page"
218− WD.openPage $ "http://localhost:" <> show jsaddlePort
219− putStrLnDebug "running beforeJS"
220− a <- beforeJS
221− putStrLnDebug "putting waitBeforeJS"
222− liftIO $ putMVar waitBeforeJS ()
223− putStrLnDebug "taking waitUntilSwitchover"
224− liftIO $ takeMVar waitUntilSwitchover
225− putStrLnDebug "running afterSwitchover"
226− afterSwitchover a
227−
228−--------------------------------------------------------------------------------
229−-- Utilities
230−--------------------------------------------------------------------------------
231−
232−-- | Embed a different spec type by evaluating it directly.
233−embedSpec :: (Hspec.Example a, MonadIO m) => Hspec.Arg a -> a -> m ()
234−embedSpec arg spec = liftIO $ do
235− Hspec.Result _info status <- Hspec.evaluateExample
236− spec
237− Hspec.defaultParams
238− (\actionWith -> actionWith arg)
239− (\_ -> pure ())
240− case status of
241− Hspec.Success -> pure ()
242− Hspec.Pending _ _ -> pure () -- should not happen
243− failure -> throwIO failure
244−
245−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
246−withAsync' f g = bracket
247− (liftIO $ Async.async f)
248− (liftIO . Async.uninterruptibleCancel)
249− (const g)
reflex-dom/ChangeLog.md−4
@@ -1,9 +1,5 @@
1# Revision history for reflex-dom
1# Revision history for reflex-dom
2
2
3−## 0.6.1.0-r1
4−
5−* Loosen reflex-dom-core version bounds
6−
7## 0.6.1.0
3## 0.6.1.0
8
4
9* Update for new dependent-map and dependent-sum (after the "some" package split)
5* Update for new dependent-map and dependent-sum (after the "some" package split)
reflex-dom/reflex-dom.cabal+3−3
@@ -61,7 +61,7 @@ library
61 hs-source-dirs: src-android
61 hs-source-dirs: src-android
62 other-modules: Reflex.Dom.Android.MainWidget
62 other-modules: Reflex.Dom.Android.MainWidget
63 build-depends:
63 build-depends:
64− aeson >= 1.4 && < 1.6,
64+ aeson >= 1.4 && < 1.5,
65 android-activity == 0.1.*,
65 android-activity == 0.1.*,
66 data-default == 0.7.*,
66 data-default == 0.7.*,
67 jsaddle >= 0.9.6 && < 0.10
67 jsaddle >= 0.9.6 && < 0.10
@@ -71,10 +71,10 @@ library
71 cpp-options: -DANDROID
71 cpp-options: -DANDROID
72 build-tools: hsc2hs
72 build-tools: hsc2hs
73 build-depends:
73 build-depends:
74− base >= 4.7 && < 4.15,
74+ base >= 4.7 && < 4.14,
75 bytestring == 0.10.*,
75 bytestring == 0.10.*,
76 reflex >= 0.8 && < 0.9,
76 reflex >= 0.8 && < 0.9,
77− reflex-dom-core >= 0.6.1.0 && <0.7,
77+ reflex-dom-core == 0.6.1.0,
78 text == 1.2.*
78 text == 1.2.*
79 if !impl(ghcjs)
79 if !impl(ghcjs)
80 if flag(use-warp) && (os(linux) || os(osx))
80 if flag(use-warp) && (os(linux) || os(osx))