marionette-1.1.0: src/Test/Marionette/Actions.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}

-- | The <W3C https://w3c.github.io/webdriver/#actions Actions> API.
module Test.Marionette.Actions where

import Data.Aeson (ToJSON (toJSON), Value (String), object, (.=))
import Data.Text (Text)
import Data.Text qualified as Text
import Test.Marionette.Element (Element)
import Test.Marionette.Key (Key)
import Prelude

-- | Where a pointer or wheel action is anchored.
data Origin
    = -- | The top-left of the viewport.
      Viewport
    | -- | The input source's current position.
      Pointer
    | -- | The centre of the given element.
      FromElement Element
    deriving stock (Show, Eq)

instance ToJSON Origin where
    toJSON Viewport = String "viewport"
    toJSON Pointer = String "pointer"
    toJSON (FromElement element) = toJSON element

-- | Which mouse button an action addresses.
data Button
    = LeftButton
    | MiddleButton
    | RightButton
    | BackButton
    | ForwardButton
    deriving stock (Show, Eq, Enum, Bounded)

-- | The kind of physical device a pointer input source represents.
data PointerType = Mouse | Pen | Touch
    deriving stock (Show, Eq)

instance ToJSON PointerType where
    toJSON = String . Text.toLower . Text.show

-- | One tick of a pointer input source's action list.
data PointerAction
    = -- | Do nothing for this many milliseconds, or until every other
      -- source's action in this tick has finished, whichever is longer.
      PointerPause {durationMs :: Int}
    | -- | Move to (or by, relative to the 'Origin') the given position over
      -- the given number of milliseconds.
      PointerMove {durationMs :: Int, origin :: Origin, x :: Int, y :: Int}
    | PointerDown Button
    | PointerUp Button
    deriving stock (Show, Eq)

instance ToJSON PointerAction where
    toJSON PointerPause{..} =
        object
            [ "type" .= String "pause"
            , "duration" .= durationMs
            ]
    toJSON PointerMove{..} =
        object
            [ "type" .= String "pointerMove"
            , "duration" .= durationMs
            , "origin" .= origin
            , "x" .= x
            , "y" .= y
            ]
    toJSON (PointerDown button) =
        object
            [ "type" .= String "pointerDown"
            , "button" .= fromEnum button
            ]
    toJSON (PointerUp button) =
        object
            [ "type" .= String "pointerUp"
            , "button" .= fromEnum button
            ]

-- | One tick of a key input source's action list.
data KeyAction
    = KeyPause {durationMs :: Int}
    | KeyDown Key
    | KeyUp Key
    deriving stock (Show, Eq)

instance ToJSON KeyAction where
    toJSON KeyPause{..} =
        object
            [ "type" .= String "pause"
            , "duration" .= durationMs
            ]
    toJSON (KeyDown key) =
        object
            [ "type" .= String "keyDown"
            , "value" .= key
            ]
    toJSON (KeyUp key) =
        object
            [ "type" .= String "keyUp"
            , "value" .= key
            ]

-- | One tick of a wheel input source's action list.
data WheelAction
    = WheelPause {durationMs :: Int}
    | -- | Scroll by the given @(deltaX, deltaY)@ pixels, anchored at the
      -- given @(x, y)@ relative to the 'Origin', over the given number of
      -- milliseconds.
      Scroll
        { durationMs :: Int
        , origin :: Origin
        , x :: Int
        , y :: Int
        , deltaX :: Int
        , deltaY :: Int
        }
    deriving stock (Show, Eq)

instance ToJSON WheelAction where
    toJSON WheelPause{..} =
        object
            [ "type" .= String "pause"
            , "duration" .= durationMs
            ]
    toJSON Scroll{..} =
        object
            [ "type" .= String "scroll"
            , "duration" .= durationMs
            , "origin" .= origin
            , "x" .= x
            , "y" .= y
            , "deltaX" .= deltaX
            , "deltaY" .= deltaY
            ]

-- | One tick of a "none" input source's action list.
newtype NoneAction = NonePause {durationMs :: Int}
    deriving stock (Show, Eq)

instance ToJSON NoneAction where
    toJSON NonePause{..} =
        object
            [ "type" .= String "pause"
            , "duration" .= durationMs
            ]

-- | A virtual input device and the sequence of actions to dispatch on it.
data InputSource
    = PointerInput
        { sourceId :: Text
        , pointerType :: PointerType
        , pointerActions :: [PointerAction]
        }
    | KeyInput
        { sourceId :: Text
        , keyActions :: [KeyAction]
        }
    | WheelInput
        { sourceId :: Text
        , wheelActions :: [WheelAction]
        }
    | NoneInput
        { sourceId :: Text
        , noneActions :: [NoneAction]
        }
    deriving stock (Show, Eq)

instance ToJSON InputSource where
    toJSON PointerInput{..} =
        object
            [ "type" .= String "pointer"
            , "id" .= sourceId
            , "parameters" .= object ["pointerType" .= pointerType]
            , "actions" .= pointerActions
            ]
    toJSON KeyInput{..} =
        object
            [ "type" .= String "key"
            , "id" .= sourceId
            , "actions" .= keyActions
            ]
    toJSON WheelInput{..} =
        object
            [ "type" .= String "wheel"
            , "id" .= sourceId
            , "actions" .= wheelActions
            ]
    toJSON NoneInput{..} =
        object
            [ "type" .= String "none"
            , "id" .= sourceId
            , "actions" .= noneActions
            ]

-- | A single mouse pointer input source named @"mouse"@.
mouse :: [PointerAction] -> InputSource
mouse = PointerInput "mouse" Mouse

-- | A single pen pointer input source named @"pen"@.
pen :: [PointerAction] -> InputSource
pen = PointerInput "pen" Pen

-- | A single touch pointer input source named @"touch"@.
touch :: [PointerAction] -> InputSource
touch = PointerInput "touch" Touch

-- | A single keyboard input source named @"keyboard"@.
keyboard :: [KeyAction] -> InputSource
keyboard = KeyInput "keyboard"

-- | A single wheel input source named @"wheel"@.
wheel :: [WheelAction] -> InputSource
wheel = WheelInput "wheel"