@@ -7,20 +7,20 @@ import Control.Monad.Aff as Aff
77import Control.Monad.Aff.Class (class MonadAff, liftAff)
88import Control.Monad.Eff.Ref as Ref
99import Control.Monad.Eff.Class (liftEff)
10−import Control.Monad.Error.Class (class MonadThrow)
1110import Control.Monad.Rec.Class (class MonadRec)
1211import Data.Argonaut as J
1312import Data.Bifunctor (lmap)
1413import Data.Either (Either(..), isRight)
1514import Data.List (List(..), (:))
15+import Data.List as L
1616import Data.Map as Map
1717import Data.Maybe (Maybe(..))
1818import Data.Symbol (SProxy(..))
1919import Data.StrMap as SM
20+import Data.String as Str
2021import Data.Variant as V
2122import Data.Time.Duration (Milliseconds(..))
2223import Data.Traversable as T
23−import Data.Tuple (Tuple(..))
2424import Lunapark.Endpoint as LP
2525import Lunapark.Error as LE
2626import Lunapark.Types as LT
@@ -32,8 +32,6 @@ import Run.Except (EXCEPT)
3232import Run.Except as RE
3333import Unsafe.Coerce (unsafeCoerce)
3434
35−--import Debug.Trace as DT
36−
3735type LunaparkEffects e =
3836 ( ajax ∷ AJAX
3937 , ref ∷ Ref.REF
@@ -53,7 +51,6 @@ init
5351 ∷ ∀ e m r a
5452 . MonadAff (LunaparkEffects e) m
5553 ⇒ MonadRec m
56− ⇒ MonadThrow LE.Error m
5754 ⇒ String
5855 → LT.CapabilitiesRequest
5956 → m (Either LE.Error (Lunapark e r a → BaseRun e r a))
@@ -82,8 +79,8 @@ init uri caps = do
8279 map isRight
8380 $ liftAff
8481 $ LP.post uri (LP.InSession session : LP.Actions : Nil)
85− $ LT.encodeActionRequest $ SM.fromFoldable
86− [ Tuple "id" $ LT.NoSource [ V.inj (SProxy ∷ SProxy "pause") $ Milliseconds 0.0 ] ]
82+ $ LT.encodeActionRequest $ SM.singleton "action-test"
83+ $ LT.NoSource [ LT.pause $ Milliseconds 0.0 ]
8784
8885 let
8986 input =
@@ -167,7 +164,7 @@ data ActionF a
167164 = Click LT.Button a
168165 | ButtonDown LT.Button a
169166 | ButtonUp LT.Button a
170− | DoubleClick a
167+ | DoubleClick LT.Button a
171168 | SendKeys String a
172169 | MoveTo LT.PointerMove a
173170 | Touch (TouchF a)
@@ -178,8 +175,8 @@ data TouchF a
178175 | TouchDown a
179176 | TouchUp a
180177 | LongClick a
181− | Flick a
182− | Scroll a
178+ | Flick LT.PointerMove a
179+ | Scroll LT.PointerMove a
183180 | DoubleTap a
184181
185182derive instance functorLunaparkF ∷ Functor LunaparkF
@@ -187,18 +184,16 @@ derive instance functorElementF ∷ Functor ElementF
187184derive instance functorActionF ∷ Functor ActionF
188185derive instance functorTouchF ∷ Functor TouchF
189186
187+type Lunapark e r = BaseRun e (lunapark ∷ LUNAPARK, lunaparkActions ∷ LUNAPARK_ACTIONS|r)
188+
190189type BaseRun e r = R.Run
191190 ( except ∷ EXCEPT LE.Error
192191 , aff ∷ R.AFF (LunaparkEffects e)
193192 , eff ∷ R.EFF (LunaparkEffects e)
194193 | r)
195194
196−type Lunapark e r = BaseRun e (lunapark ∷ LUNAPARK, lunaparkActions ∷ LUNAPARK_ACTIONS|r)
197−
198195_lunapark = SProxy ∷ SProxy "lunapark"
199−_lunaparkActions = SProxy ∷ SProxy "lunaparkActions"
200196type LUNAPARK = R.FProxy LunaparkF
201−type LUNAPARK_ACTIONS = R.FProxy ActionF
202197type WithLunapark r a = R.Run (lunapark ∷ LUNAPARK|r) a
203198
204199liftLunapark ∷ ∀ a r. LunaparkF a → WithLunapark r a
@@ -363,6 +358,57 @@ performActions req = liftLunapark $ PerformActions req unit
363358releaseActions ∷ ∀ r. WithLunapark r Unit
364359releaseActions = liftLunapark $ ReleaseActions unit
365360
361+-- ACTIONS
362+_lunaparkActions = SProxy ∷ SProxy "lunaparkActions"
363+type LUNAPARK_ACTIONS = R.FProxy ActionF
364+type WithAction r = R.Run (lunaparkActions ∷ LUNAPARK_ACTIONS|r) Unit
365+
366+liftAction ∷ ∀ r. ActionF Unit → WithAction r
367+liftAction = R.lift _lunaparkActions
368+
369+click ∷ ∀ r. LT.Button → WithAction r
370+click btn = liftAction $ Click btn unit
371+
372+buttonDown ∷ ∀ r. LT.Button → WithAction r
373+buttonDown btn = liftAction $ ButtonDown btn unit
374+
375+buttonUp ∷ ∀ r. LT.Button → WithAction r
376+buttonUp btn = liftAction $ ButtonUp btn unit
377+
378+doubleClick ∷ ∀ r. LT.Button → WithAction r
379+doubleClick btn = liftAction $ DoubleClick btn unit
380+
381+sendKeys ∷ ∀ r. String → WithAction r
382+sendKeys txt = liftAction $ SendKeys txt unit
383+
384+moveTo ∷ ∀ r. LT.PointerMove → WithAction r
385+moveTo move = liftAction $ MoveTo move unit
386+
387+pause ∷ ∀ r. Milliseconds → WithAction r
388+pause ms = liftAction $ Pause ms unit
389+
390+tap ∷ ∀ r. WithAction r
391+tap = liftAction $ Touch $ Tap unit
392+
393+touchDown ∷ ∀ r. WithAction r
394+touchDown = liftAction $ Touch $ TouchDown unit
395+
396+touchUp ∷ ∀ r. WithAction r
397+touchUp = liftAction $ Touch $ TouchUp unit
398+
399+longTap ∷ ∀ r. WithAction r
400+longTap = liftAction $ Touch $ LongClick unit
401+
402+flick ∷ ∀ r. LT.PointerMove → WithAction r
403+flick move = liftAction $ Touch $ Flick move unit
404+
405+scroll ∷ ∀ r. LT.PointerMove → WithAction r
406+scroll move = liftAction $ Touch $ Scroll move unit
407+
408+doubleTap ∷ ∀ r. WithAction r
409+doubleTap = liftAction $ Touch $ DoubleTap unit
410+
411+-- Interpreters
366412runLunapark ∷ ∀ e r. HandleLunaparkInput → BaseRun e (lunapark ∷ LUNAPARK|r) ~> BaseRun e r
367413runLunapark input = do
368414 R.interpretRec (R.on _lunapark (handleLunapark input) R.send)
@@ -370,51 +416,109 @@ runLunapark input = do
370416runLunaparkActions ∷ ∀ e r. HandleLunaparkInput → Lunapark e r ~> BaseRun e (lunapark ∷ LUNAPARK|r)
371417runLunaparkActions input =
372418 if input.actionsEnabled
373− then interpretW3CActions input SM.empty
419+ then interpretW3CActions input Nil
374420 else R.interpretRec (R.on _lunaparkActions (jsonWireActions input) R.send)
375421
376422interpretW3CActions
377423 ∷ ∀ e r
378424 . HandleLunaparkInput
379− → LT.ActionRequest
425+ → List LT.ActionSequence
380426 → Lunapark e r
381427 ~> BaseRun e (lunapark ∷ LUNAPARK|r)
382428interpretW3CActions inp acc as = case R.peel as of
383429 Left la → case tag la of
384430 Left a → w3cActions acc (interpretW3CActions inp) a
385431 Right others → do
386− performActions acc
432+ T.for_ (L.reverse acc) \s → performActions $ SM.singleton "dummy" s
387433 cont ← R.send others
388− interpretW3CActions inp SM.empty cont
434+ interpretW3CActions inp Nil cont
389435 Right a → pure a
390436 where
391437 tag = R.on _lunaparkActions Left Right
392438
393439w3cActions
394440 ∷ ∀ e r a
395− . LT.ActionRequest
396− → ( LT.ActionRequest
441+ . List LT.ActionSequence
442+ → ( List LT.ActionSequence
397443 → Lunapark e r
398444 ~> BaseRun e (lunapark ∷ LUNAPARK|r)
399445 )
400446 → ActionF (Lunapark e r a)
401447 → BaseRun e (lunapark ∷ LUNAPARK|r) a
402448w3cActions acc loop = case _ of
403− Click btn next → loop acc next
404− ButtonDown btn next → loop acc next
405− ButtonUp btn next → loop acc next
406− DoubleClick next → loop acc next
407− MoveTo move next → loop acc next
408− SendKeys txt next → loop acc next
409− Pause ms next → loop acc next
449+ Click btn next →
450+ let seq = [ LT.pointerDown btn, LT.pointerUp btn ]
451+ in loop (inMouse seq) next
452+ ButtonDown btn next →
453+ let seq = [ LT.pointerDown btn ]
454+ in loop (inMouse seq) next
455+ ButtonUp btn next →
456+ let seq = [ LT.pointerUp btn ]
457+ in loop (inMouse seq) next
458+ DoubleClick btn next →
459+ let seq = [ LT.pointerDown btn, LT.pointerUp btn, LT.pointerDown btn, LT.pointerUp btn ]
460+ in loop (inMouse seq) next
461+ MoveTo move next →
462+ let seq = [ LT.pointerMove move ]
463+ in loop (inPointer seq) next
464+ SendKeys txt next →
465+ let seq = T.foldMap (\ch → [ LT.keyDown ch, LT.keyUp ch ]) $ Str.toCharArray txt
466+ in loop (inKeys seq) next
467+ Pause ms next →
468+ let seq = [ LT.pause ms ]
469+ in loop (anywhere seq) next
410470 Touch tch → case tch of
411− Tap next → loop acc next
412− TouchDown next → loop acc next
413− TouchUp next → loop acc next
414− LongClick next → loop acc next
415− Flick next → loop acc next
416− Scroll next → loop acc next
417− DoubleTap next → loop acc next
471+ Tap next →
472+ let seq = [ LT.pointerDown LT.LeftBtn, LT.pointerUp LT.LeftBtn ]
473+ in loop (inTouch seq) next
474+ TouchDown next →
475+ let seq = [ LT.pointerDown LT.LeftBtn ]
476+ in loop (inTouch seq) next
477+ TouchUp next →
478+ let seq = [ LT.pointerUp LT.LeftBtn ]
479+ in loop (inTouch seq) next
480+ LongClick next →
481+ let seq = [ LT.pointerDown LT.LeftBtn, LT.pause (Milliseconds 3000.0), LT.pointerUp LT.LeftBtn ]
482+ in loop (inTouch seq) next
483+ Flick move next →
484+ let seq = [ LT.pointerMove move ]
485+ in loop (inTouch seq) next
486+ Scroll move next →
487+ let seq = [ LT.pointerMove move ]
488+ in loop (inTouch seq) next
489+ DoubleTap next →
490+ let seq = [ LT.pointerDown LT.LeftBtn, LT.pointerUp LT.LeftBtn, LT.pointerDown LT.LeftBtn, LT.pointerUp LT.LeftBtn ]
491+ in loop (inTouch seq) next
492+ where
493+ unconsed = L.uncons acc
494+
495+ inMouse seq = case unconsed of
496+ Just { head: (LT.Pointer LT.Mouse as), tail } →
497+ LT.Pointer LT.Mouse (as <> seq) : tail
498+ _ → LT.Pointer LT.Mouse seq : acc
499+
500+ inPointer seq = case unconsed of
501+ Just { head: (LT.Pointer ptr as), tail } →
502+ LT.Pointer ptr (as <> seq) : tail
503+ _ → LT.Pointer LT.Mouse seq : acc
504+
505+ inKeys seq = case unconsed of
506+ Just { head: LT.Key as, tail } →
507+ LT.Key (as <> seq) : tail
508+ _ → LT.Key seq : acc
509+
510+ inTouch seq = case unconsed of
511+ Just { head: (LT.Pointer LT.Touch as), tail } →
512+ LT.Pointer LT.Touch (as <> seq) : tail
513+ _ → LT.Pointer LT.Mouse seq : acc
514+
515+ anywhere ∷ Array (V.Variant (pause ∷ Milliseconds)) → L.List LT.ActionSequence
516+ anywhere seq = case unconsed of
517+ Nothing → L.singleton $ LT.NoSource seq
518+ Just { head, tail } → case head of
519+ LT.Pointer ptr as → LT.Pointer ptr (as <> map V.expand seq) : tail
520+ LT.Key as → LT.Key (as <> map V.expand seq) : tail
521+ LT.NoSource as → LT.NoSource (as <> seq) : tail
418522
419523type HandleLunaparkInput =
420524 { session ∷ LT.SessionId
@@ -436,8 +540,12 @@ jsonWireActions inp = case _ of
436540 ButtonUp btn next → do
437541 _ ← post (LP.ButtonUp : Nil) (LT.encodeButton btn)
438542 pure next
439− DoubleClick next → do
440− _ ← post_ (LP.DoubleClick : Nil)
543+ DoubleClick btn next → do
544+ _ ← case btn of
545+ LT.LeftBtn → post_ (LP.DoubleClick : Nil)
546+ other → do
547+ _ ← post (LP.Click : Nil) (LT.encodeButton btn)
548+ post (LP.Click : Nil) (LT.encodeButton btn)
441549 pure next
442550 SendKeys txt next → do
443551 _ ← post (LP.Keys : Nil) (LT.encodeSendKeysRequest txt)
@@ -466,11 +574,21 @@ jsonWireActions inp = case _ of
466574 LongClick next → do
467575 _ ← post_ (LP.Touch : LP.LongClick : Nil)
468576 pure next
469− Flick next → do
470− _ ← post_ (LP.Touch : LP.Flick : Nil)
577+ Flick move next → do
578+ element ← case move.origin of
579+ LT.FromViewport → map Just $ findElement $ LT.ByTagName "body"
580+ LT.FromPointer → pure Nothing
581+ LT.FromElement el → pure $ Just el
582+ let req = { xoffset: move.x, yoffset: move.y, element }
583+ _ ← post (LP.Touch : LP.Flick : Nil) (LT.encodeMoveToRequest req)
471584 pure next
472− Scroll next → do
473− _ ← post_ (LP.Touch : LP.Scroll : Nil)
585+ Scroll move next → do
586+ element ← case move.origin of
587+ LT.FromViewport → map Just $ findElement $ LT.ByTagName "body"
588+ LT.FromPointer → pure Nothing
589+ LT.FromElement el → pure $ Just el
590+ let req = { xoffset: move.x, yoffset: move.y, element }
591+ _ ← post (LP.Touch : LP.Scroll : Nil) (LT.encodeMoveToRequest req)
474592 pure next
475593 DoubleTap next → do
476594 _ ← post_ (LP.Touch : LP.DoubleClick : Nil)