ilyakooo0/reflex-dom
1
0
Fork 0
mirror of https://github.com/ilyakooo0/reflex-dom.git synced 2024-08-15 17:40:26 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #418 from reflex-frp/ts@tiny-test-fixes

Browse Source 
Tiny test fixes
This commit is contained in:
John Ericson 2021-09-10 18:17:09 -04:00 committed by GitHub
commit f15b8dca9f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 47 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
reflex-dom-core/ChangeLog.md
View File

@ -1,5 +1,9 @@
# Revision history for reflex-dom-core
## 0.6.2.1
* Fix hlint complaints with newer GHC.
## 0.6.2.0
* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer

4
reflex-dom-core/reflex-dom-core.cabal
View File

@ -176,7 +176,9 @@ library
Reflex.Dom.Builder.Class.TH
test-suite hlint
build-depends: base, hlint
build-depends:
base,
hlint >= 2.0 && < 4.0
hs-source-dirs: test
main-is: hlint.hs
type: exitcode-stdio-1.0

3
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs
View File

@ -9,11 +9,12 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
#if !MIN_VERSION_base(4,9,0)
{-# LANGUAGE ImpredicativeTypes #-}
#else
{-# LANGUAGE Rank2Types #-} -- Implied by ImpredicativeTypes
#endif
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

5
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
@ -1877,14 +1876,14 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
getHydrationMode >>= \case
HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
phs <- sequenceA $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
liftIO $ writeIORef placeholders $! phs
insertAfterPreviousNode lastPlaceholder
HydrationMode_Immediate -> do
let activate i = do
append $ toNode $ _traverseChildImmediate_fragment i
pure $ _traverseChildImmediate_placeholder i
phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
liftIO $ writeIORef placeholders $! phs
append $ toNode lastPlaceholder
requestDomAction_ $ ffor children' $ \p -> do

2
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs
View File

@ -274,7 +274,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
--TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
modify . (:) =<< (\c -> "<!--" <> c <> "-->") <$> case mSetContents of
(modify . (:)) . (\c -> "<!--" <> c <> "-->") =<< case mSetContents of
Nothing -> return (pure (escape initialContents))
Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
return $ CommentNode ()

1
reflex-dom-core/src/Reflex/Dom/Main.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}

2
reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hs
View File

@ -117,7 +117,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
"overflow" =: "hidden" <>
"position" =: "relative"
mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
"top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
"top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <>
"position" =: "absolute" <>
"width" =: "100%"
findWindow sizeIncrement windowSize startingPosition =

2
reflex-dom-core/test/hlint.hs
View File

@ -1,4 +1,4 @@
import Language.Haskell.HLint3 (hlint)
import Language.Haskell.HLint (hlint)
import System.Exit (exitFailure, exitSuccess)
main :: IO ()

59
reflex-dom-core/test/hydration.hs
View File

@ -20,6 +20,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- Notice to those working on this test suite:
-- It doesn't appear to be possible to use --match to run a particular test, in
-- this situation the test may hang before reaching our code. This seems to
-- happen when the test is not the first test in the block. As a workaround, you
-- can just comment out the other tests. Also, using `xit` will cause the same
-- issue. `xit` tests must be the last tests in the session, or the session will
-- hang in the following test.
import Prelude hiding (fail)
import Control.Concurrent
import qualified Control.Concurrent.Async as Async
@ -146,13 +154,13 @@ main = do
withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
tests withDebugging wdConfig caps _selenium = do
let putStrLnDebug :: MonadIO m => Text -> m ()
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
session' = sessionWith wdConfig "" . using (map (,"") caps)
session' t = sessionWith wdConfig t . using caps
runWD m = runWDOptions (WdOptions False) $ do
putStrLnDebug "before"
r <- m
@ -164,7 +172,7 @@ tests withDebugging wdConfig caps _selenium = do
testWidget = testWidgetDebug True withDebugging
testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
testWidget' = testWidgetDebug' True withDebugging
describe "text" $ session' $ do
session' "text" $ do
it "works" $ runWD $ do
testWidgetStatic (checkBodyText "hello world") $ do
text "hello world"
@ -225,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do
click <- button ""
void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
describe "element" $ session' $ do
session' "element" $ do
it "works with domEvent Click" $ runWD $ do
clickedRef <- liftIO $ newRef False
testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@ -289,8 +297,8 @@ tests withDebugging wdConfig caps _selenium = do
let click = domEvent Click e
return ()
describe "inputElement" $ do
describe "static renderer" $ session' $ do
session' "inputElement" $ do
describe "static renderer" $ do
it "sets value attribute" $ runWD $ do
let checkStatic = do
e <- findElemWithRetry $ WD.ByTag "input"
@ -347,7 +355,7 @@ tests withDebugging wdConfig caps _selenium = do
& inputElementConfig_initialChecked .~ False
& inputElementConfig_setChecked .~ (True <$ pb)
pure ()
describe "hydration" $ session' $ do
describe "hydration" $ do
it "doesn't wipe user input when switching over" $ runWD $ do
inputRef <- newRef ("hello " :: Text)
testWidget'
@ -585,8 +593,7 @@ tests withDebugging wdConfig caps _selenium = do
el "p" $ dynText $ _inputElement_value e
performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
performEvent_ $ consRef inputRef <$> _inputElement_input e
describe "hydration/immediate" $ session' $ do
describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@ -666,8 +673,8 @@ tests withDebugging wdConfig caps _selenium = do
names <- liftJSM $ traverse File.getName fs
liftIO $ writeRef filesRef names
describe "textAreaElement" $ do
describe "static renderer" $ session' $ do
session' "textAreaElement" $ do
describe "static renderer" $ do
it "sets value attribute" $ runWD $ do
let checkStatic = do
e <- findElemWithRetry $ WD.ByTag "textarea"
@ -690,7 +697,7 @@ tests withDebugging wdConfig caps _selenium = do
& textAreaElementConfig_initialValue .~ "test"
& textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
pure ()
describe "hydration" $ session' $ do
describe "hydration" $ do
it "doesn't wipe user input when switching over" $ runWD $ do
inputRef <- newRef ("" :: Text)
testWidget'
@ -839,7 +846,7 @@ tests withDebugging wdConfig caps _selenium = do
e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
el "p" $ dynText $ _textAreaElement_value e
describe "hydration/immediate" $ session' $ do
describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@ -881,13 +888,13 @@ tests withDebugging wdConfig caps _selenium = do
performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
describe "selectElement" $ do
session' "selectElement" $ do
let options :: DomBuilder t m => m ()
options = do
elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
describe "hydration" $ session' $ do
describe "hydration" $ do
it "sets initial value correctly" $ runWD $ do
inputRef <- newRef ("" :: Text)
let setup = do
@ -961,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
describe "hydration/immediate" $ session' $ do
describe "hydration/immediate" $ do
it "captures user input after switchover" $ runWD $ do
inputRef :: IORef Text <- newRef ""
let checkValue = do
@ -1007,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
describe "prerender" $ session' $ do
session' "prerender" $ do
it "works in simple case" $ runWD $ do
testWidget (checkBodyText "One") (checkBodyText "Two") $ do
prerender_ (text "One") (text "Two")
@ -1076,7 +1083,7 @@ tests withDebugging wdConfig caps _selenium = do
prerender_ (pure ()) (liftIO $ trigger "Client")
textNode $ TextNodeConfig "Initial" $ Just e
describe "namespaces" $ session' $ do
session' "namespaces" $ do
it "dyn can be nested in namespaced widget" $ runWD $ do
testWidget (pure ()) (checkTextInTag "svg" "one") $ do
let svgRootCfg = def
@ -1085,7 +1092,7 @@ tests withDebugging wdConfig caps _selenium = do
void $ element "svg" svgRootCfg $ do
dyn_ $ text "one" <$ pure ()
describe "runWithReplace" $ session' $ do
session' "runWithReplace" $ do
it "works" $ runWD $ do
replaceChan :: Chan Text <- liftIO newChan
let setup = findElemWithRetry $ WD.ByTag "div"
@ -1283,7 +1290,7 @@ tests withDebugging wdConfig caps _selenium = do
_ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
text "|after"
describe "traverseDMapWithKeyWithAdjust" $ session' $ do
session' "traverseDMapWithKeyWithAdjust" $ do
let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
elClass "span" "key" $ text $ textKey k
@ -1386,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
liftIO $ dmap `H.shouldBe` keyMap
describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
session' "traverseIntMapWithKeyWithAdjust" $ do
let textKeyInt k = "key" <> T.pack (show k)
intMap = IntMap.fromList
[ (1, "one")
@ -1493,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
liftIO $ dmap `H.shouldBe` intMap
describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
session' "traverseDMapWithKeyWithAdjustWithMove" $ do
let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
elClass "span" "key" $ text $ textKey2 k
@ -1573,8 +1580,8 @@ tests withDebugging wdConfig caps _selenium = do
(dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
liftIO $ assertEqual "DMap" initMap dmap
describe "hydrating invalid HTML" $ session' $ do
it "can hydrate list in paragraph" $ runWD $ do
session' "hydrating invalid HTML" $ do
xit "can hydrate list in paragraph" $ runWD $ do
let preSwitchover = do
checkBodyText "before\ninner\nafter"
-- Two <p> tags should be present
@ -1603,7 +1610,7 @@ tests withDebugging wdConfig caps _selenium = do
-- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
-- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
-- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
describe "dropdown" $ session' $ do
session' "dropdown" $ do
let doTest expectedOpts (initialValue :: Text) = do
let doCheck = do
es <- findElemsWithRetry $ WD.ByTag "option"