Mouse.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-}

module TestLib.Mouse (
  assertWithinPixels
  , getBoundingClientRect
  , getElementCenter

  , MouseEventType(..)
  , MouseEvent(..)
  , ClientRect(..)
  ) where

import Control.Monad.IO.Class
import Data.Aeson as A
import Data.String.Interpolate
import qualified Data.Text as T
import GHC.Generics
import Test.Sandwich
import Test.WebDriver
import TestLib.Types


data MouseEventType =
  MouseEventTypeClick
  | MouseEventTypeDoubleClick
  | MouseEventTypeContextMenu
  deriving (Show, Eq)
instance FromJSON MouseEventType where
  parseJSON (String "click") = pure MouseEventTypeClick
  parseJSON (String "dblclick") = pure MouseEventTypeDoubleClick
  parseJSON (String "contextmenu") = pure MouseEventTypeContextMenu
  parseJSON x = fail [i|Unexpected mouse event type: #{x}|]

data MouseEvent = MouseEvent {
  eventType :: MouseEventType
  , screenX :: Int
  , screenY :: Int
  , clientX :: Int
  , clientY :: Int
  , pageX :: Int
  , pageY :: Int
  , button :: Int
  } deriving (Show, Eq, Generic, FromJSON)

data ClientRect = ClientRect {
  bottom :: Double
  , height :: Double
  , left :: Double
  , right :: Double
  , top :: Double
  , width :: Double
  , x :: Double
  , y :: Double
  } deriving (Show, Eq, Generic, FromJSON)

assertWithinPixels :: (MonadIO m) => (Double, Double) -> (Double, Double) -> Double -> m ()
assertWithinPixels (x1, y1) (x2, y2) tolerance =
  if | d <= tolerance -> return ()
     | otherwise -> expectationFailure [i|Points were supposed to be within #{tolerance}, but distance was #{d}|]
  where
    d = sqrt ((x2 - x1)**2 + (y2 - y1)**2)

getBoundingClientRect :: (HasSession ctx) => T.Text -> ExampleT ctx IO ClientRect
getBoundingClientRect cssSelector =
  executeJS [JSArg cssSelector] [i|return document.querySelector(arguments[0]).getBoundingClientRect()|]

getElementCenter :: (HasSession ctx) => T.Text -> ExampleT ctx IO (Double, Double)
getElementCenter cssSelector = do
  ClientRect {..} <- getBoundingClientRect cssSelector
  return (left + (width / 2.0), top + (height / 2.0))