fix: listen should not be async by default

This commit is contained in:
orion 2023-10-07 11:28:24 -05:00
parent b59de0f5b5
commit f126123369
Signed by: orion
GPG Key ID: 6D4165AE4C928719
3 changed files with 12 additions and 11 deletions

View File

@ -40,10 +40,10 @@ import Puppeteer.Page.Event.ConsoleMessage as ConsoleMessage
import Puppeteer.Page.Event.Dialog (Dialog)
import Simple.JSON (class ReadForeign, readImpl)
connectPageConsole :: Page -> Aff Unit
connectPageConsole :: Page -> Effect Unit
connectPageConsole p =
let
onmsg m = do
onmsg m = launchAff_ do
title <- Page.title p
let t = ConsoleMessage.messageType m
let textLevel = "[" <> String.toUpper (messageTypeString t) <> "]"
@ -149,13 +149,13 @@ once ev p =
in
makeAff f
listen :: forall ev evd. Event ev evd => ev -> (evd -> Aff Unit) -> Page -> Aff (Context "event listener")
listen :: forall ev evd. Event ev evd => ev -> (evd -> Effect Unit) -> Page -> Effect (Context "event listener")
listen ev cb p =
let
cb' f = unsafePerformEffect $ do
evd <- liftEither $ lmap error $ note "parse failed" $ eventData f
launchAff_ $ cb evd
cb evd
in
do
t <- liftEffect $ _addListener (eventKey ev) cb' p
t <- _addListener (eventKey ev) cb' p
pure $ Context (\_ -> liftEffect $ _removeListener t p)

View File

@ -10,7 +10,8 @@ import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (wrap)
import Effect (Effect)
import Effect.Aff (Aff, delay, forkAff, joinFiber)
import Effect.Class (liftEffect)
import Effect.Aff (Aff, launchAff_, delay, forkAff, joinFiber)
import Effect.Exception as Error
import Puppeteer (timeout)
import Puppeteer as Pup
@ -68,7 +69,7 @@ spec =
withPage $ test "listen PageError" \p -> do
errorsST <- liftST $ ST.Ref.new []
let handle = void <<< liftST <<< flip ST.Ref.modify errorsST <<< Array.cons
listening <- Pup.Page.Event.listen Pup.Page.Event.PageError handle p
listening <- liftEffect $ Pup.Page.Event.listen Pup.Page.Event.PageError handle p
void $ Pup.Page.addScriptTag (Pup.Page.AddScriptInline scriptError) p
err <- timeoutThrow (wrap 1000.0) $ untilJust (liftST $ Array.head <$> ST.Ref.read errorsST)
Error.message err `shouldEqual` "eek!"
@ -116,7 +117,7 @@ spec =
{ body = Just (Left "console.log('hi')")
, contentType = Just "text/javascript"
}
let
onrequest c r = do
untilJust do
continue <- liftST $ ST.Ref.read continueST

View File

@ -150,7 +150,7 @@ spec = beforeAll (Pup.launch_ =<< Pup.new)
test "addStyleTag" \b -> do
p <- Pup.Page.new b
connectPageConsole p
liftEffect $ connectPageConsole p
failOnPageError p do
Pup.Page.setContent simplePage Pup.Load p
_ <- Pup.Page.addStyleTag (Pup.Page.AddStyleInline styleFoo) p
@ -162,7 +162,7 @@ spec = beforeAll (Pup.launch_ =<< Pup.new)
test "addScriptTag" \b -> do
p <- Pup.Page.new b
connectPageConsole p
liftEffect $ connectPageConsole p
failOnPageError p do
Pup.Page.setContent simplePage Pup.Load p
_ <- Pup.Page.addScriptTag (Pup.Page.AddScriptInline scriptAddBar) p
@ -171,7 +171,7 @@ spec = beforeAll (Pup.launch_ =<< Pup.new)
test "keyboard" \b -> do
p <- Pup.Page.new b
connectPageConsole p
liftEffect $ connectPageConsole p
failOnPageError p do
Pup.Page.setContent inputPage Pup.Load p
input <- liftMaybe (error "no inputs!") =<< Pup.Page.findFirst "input" p