-----------------------------------------------------------------------------
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Event.Types
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Event.Types
  ( -- ** Types
    Events
    -- *** KeyboardEvent
  , KeyInfo (..)
  , KeyCode (..)
    -- *** CheckedEvent
  , Checked (..)
    -- *** PointerEvent
  , PointerEvent (..)
  , PointerType (..)
    -- *** Options
  , Options (..)
  , defaultOptions
  , preventDefault
  , stopPropagation
    -- *** Events
  , defaultEvents
  , keyboardEvents
  , mouseEvents
  , dragEvents
  , pointerEvents
  , mediaEvents
  , clipboardEvents
  , touchEvents
  ) where
-----------------------------------------------------------------------------
import           Data.Aeson (FromJSON(..), withText)
import qualified Data.Map.Strict as M
import           GHC.Generics (Generic)
import           Language.Javascript.JSaddle (ToJSVal(..), create)
import           Miso.String (MisoString, ms)
import qualified Miso.FFI as FFI
-----------------------------------------------------------------------------
-- | Type useful for both KeyCode and additional key press information.
data KeyInfo
  = KeyInfo
  { KeyInfo -> KeyCode
keyCode :: !KeyCode
  , KeyInfo -> Bool
shiftKey, KeyInfo -> Bool
metaKey, KeyInfo -> Bool
ctrlKey, KeyInfo -> Bool
altKey :: !Bool
  } deriving (Int -> KeyInfo -> ShowS
[KeyInfo] -> ShowS
KeyInfo -> String
(Int -> KeyInfo -> ShowS)
-> (KeyInfo -> String) -> ([KeyInfo] -> ShowS) -> Show KeyInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyInfo -> ShowS
showsPrec :: Int -> KeyInfo -> ShowS
$cshow :: KeyInfo -> String
show :: KeyInfo -> String
$cshowList :: [KeyInfo] -> ShowS
showList :: [KeyInfo] -> ShowS
Show, KeyInfo -> KeyInfo -> Bool
(KeyInfo -> KeyInfo -> Bool)
-> (KeyInfo -> KeyInfo -> Bool) -> Eq KeyInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyInfo -> KeyInfo -> Bool
== :: KeyInfo -> KeyInfo -> Bool
$c/= :: KeyInfo -> KeyInfo -> Bool
/= :: KeyInfo -> KeyInfo -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Type used for Keyboard events.
--
-- See <https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent/keyCode#Browser_compatibility>
newtype KeyCode = KeyCode Int
  deriving (Int -> KeyCode -> ShowS
[KeyCode] -> ShowS
KeyCode -> String
(Int -> KeyCode -> ShowS)
-> (KeyCode -> String) -> ([KeyCode] -> ShowS) -> Show KeyCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyCode -> ShowS
showsPrec :: Int -> KeyCode -> ShowS
$cshow :: KeyCode -> String
show :: KeyCode -> String
$cshowList :: [KeyCode] -> ShowS
showList :: [KeyCode] -> ShowS
Show, KeyCode -> KeyCode -> Bool
(KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> Bool) -> Eq KeyCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyCode -> KeyCode -> Bool
== :: KeyCode -> KeyCode -> Bool
$c/= :: KeyCode -> KeyCode -> Bool
/= :: KeyCode -> KeyCode -> Bool
Eq, Eq KeyCode
Eq KeyCode =>
(KeyCode -> KeyCode -> Ordering)
-> (KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> KeyCode)
-> (KeyCode -> KeyCode -> KeyCode)
-> Ord KeyCode
KeyCode -> KeyCode -> Bool
KeyCode -> KeyCode -> Ordering
KeyCode -> KeyCode -> KeyCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyCode -> KeyCode -> Ordering
compare :: KeyCode -> KeyCode -> Ordering
$c< :: KeyCode -> KeyCode -> Bool
< :: KeyCode -> KeyCode -> Bool
$c<= :: KeyCode -> KeyCode -> Bool
<= :: KeyCode -> KeyCode -> Bool
$c> :: KeyCode -> KeyCode -> Bool
> :: KeyCode -> KeyCode -> Bool
$c>= :: KeyCode -> KeyCode -> Bool
>= :: KeyCode -> KeyCode -> Bool
$cmax :: KeyCode -> KeyCode -> KeyCode
max :: KeyCode -> KeyCode -> KeyCode
$cmin :: KeyCode -> KeyCode -> KeyCode
min :: KeyCode -> KeyCode -> KeyCode
Ord, Maybe KeyCode
Value -> Parser [KeyCode]
Value -> Parser KeyCode
(Value -> Parser KeyCode)
-> (Value -> Parser [KeyCode]) -> Maybe KeyCode -> FromJSON KeyCode
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser KeyCode
parseJSON :: Value -> Parser KeyCode
$cparseJSONList :: Value -> Parser [KeyCode]
parseJSONList :: Value -> Parser [KeyCode]
$comittedField :: Maybe KeyCode
omittedField :: Maybe KeyCode
FromJSON)
-----------------------------------------------------------------------------
-- | Type used for Checkbox events.
newtype Checked = Checked Bool
  deriving (Int -> Checked -> ShowS
[Checked] -> ShowS
Checked -> String
(Int -> Checked -> ShowS)
-> (Checked -> String) -> ([Checked] -> ShowS) -> Show Checked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Checked -> ShowS
showsPrec :: Int -> Checked -> ShowS
$cshow :: Checked -> String
show :: Checked -> String
$cshowList :: [Checked] -> ShowS
showList :: [Checked] -> ShowS
Show, Checked -> Checked -> Bool
(Checked -> Checked -> Bool)
-> (Checked -> Checked -> Bool) -> Eq Checked
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Checked -> Checked -> Bool
== :: Checked -> Checked -> Bool
$c/= :: Checked -> Checked -> Bool
/= :: Checked -> Checked -> Bool
Eq, Eq Checked
Eq Checked =>
(Checked -> Checked -> Ordering)
-> (Checked -> Checked -> Bool)
-> (Checked -> Checked -> Bool)
-> (Checked -> Checked -> Bool)
-> (Checked -> Checked -> Bool)
-> (Checked -> Checked -> Checked)
-> (Checked -> Checked -> Checked)
-> Ord Checked
Checked -> Checked -> Bool
Checked -> Checked -> Ordering
Checked -> Checked -> Checked
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Checked -> Checked -> Ordering
compare :: Checked -> Checked -> Ordering
$c< :: Checked -> Checked -> Bool
< :: Checked -> Checked -> Bool
$c<= :: Checked -> Checked -> Bool
<= :: Checked -> Checked -> Bool
$c> :: Checked -> Checked -> Bool
> :: Checked -> Checked -> Bool
$c>= :: Checked -> Checked -> Bool
>= :: Checked -> Checked -> Bool
$cmax :: Checked -> Checked -> Checked
max :: Checked -> Checked -> Checked
$cmin :: Checked -> Checked -> Checked
min :: Checked -> Checked -> Checked
Ord, Maybe Checked
Value -> Parser [Checked]
Value -> Parser Checked
(Value -> Parser Checked)
-> (Value -> Parser [Checked]) -> Maybe Checked -> FromJSON Checked
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Checked
parseJSON :: Value -> Parser Checked
$cparseJSONList :: Value -> Parser [Checked]
parseJSONList :: Value -> Parser [Checked]
$comittedField :: Maybe Checked
omittedField :: Maybe Checked
FromJSON)
-----------------------------------------------------------------------------
-- | Type used for Pointer events.
-- <https://w3c.github.io/pointerevents>
data PointerEvent
  = PointerEvent
  { PointerEvent -> PointerType
pointerType :: PointerType
  , PointerEvent -> Int
pointerId :: Int
  , PointerEvent -> Bool
isPrimary :: Bool
  , PointerEvent -> (Double, Double)
client :: (Double, Double)
  -- ^ clientX, clientY
  , PointerEvent -> (Double, Double)
screen :: (Double, Double)
  -- ^ screenX, screenY
  , PointerEvent -> (Double, Double)
offset :: (Double, Double)
  -- ^ offsetX, offsetY
  , PointerEvent -> (Double, Double)
page :: (Double,Double)
  -- ^ pageX, pageY
  , PointerEvent -> (Double, Double)
tilt :: (Double,Double)
  -- ^ tiltX, tiltY
  , PointerEvent -> Double
pressure :: Double
  , PointerEvent -> Int
button :: Int
  -- ^ https://w3c.github.io/pointerevents/#the-button-property
  } deriving (Int -> PointerEvent -> ShowS
[PointerEvent] -> ShowS
PointerEvent -> String
(Int -> PointerEvent -> ShowS)
-> (PointerEvent -> String)
-> ([PointerEvent] -> ShowS)
-> Show PointerEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PointerEvent -> ShowS
showsPrec :: Int -> PointerEvent -> ShowS
$cshow :: PointerEvent -> String
show :: PointerEvent -> String
$cshowList :: [PointerEvent] -> ShowS
showList :: [PointerEvent] -> ShowS
Show, PointerEvent -> PointerEvent -> Bool
(PointerEvent -> PointerEvent -> Bool)
-> (PointerEvent -> PointerEvent -> Bool) -> Eq PointerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PointerEvent -> PointerEvent -> Bool
== :: PointerEvent -> PointerEvent -> Bool
$c/= :: PointerEvent -> PointerEvent -> Bool
/= :: PointerEvent -> PointerEvent -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Pointer type
-- <https://developer.mozilla.org/en-US/docs/Web/API/PointerEvent/pointerType>
data PointerType
  = MousePointerType
  | PenPointerType
  | TouchPointerType
  | UnknownPointerType MisoString
  deriving (Int -> PointerType -> ShowS
[PointerType] -> ShowS
PointerType -> String
(Int -> PointerType -> ShowS)
-> (PointerType -> String)
-> ([PointerType] -> ShowS)
-> Show PointerType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PointerType -> ShowS
showsPrec :: Int -> PointerType -> ShowS
$cshow :: PointerType -> String
show :: PointerType -> String
$cshowList :: [PointerType] -> ShowS
showList :: [PointerType] -> ShowS
Show, PointerType -> PointerType -> Bool
(PointerType -> PointerType -> Bool)
-> (PointerType -> PointerType -> Bool) -> Eq PointerType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PointerType -> PointerType -> Bool
== :: PointerType -> PointerType -> Bool
$c/= :: PointerType -> PointerType -> Bool
/= :: PointerType -> PointerType -> Bool
Eq)
-----------------------------------------------------------------------------
instance FromJSON PointerType where
  parseJSON :: Value -> Parser PointerType
parseJSON = String
-> (Text -> Parser PointerType) -> Value -> Parser PointerType
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"PointerType" ((Text -> Parser PointerType) -> Value -> Parser PointerType)
-> (Text -> Parser PointerType) -> Value -> Parser PointerType
forall a b. (a -> b) -> a -> b
$ \case
    Text
"mouse" -> PointerType -> Parser PointerType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PointerType
MousePointerType
    Text
"touch" -> PointerType -> Parser PointerType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PointerType
TouchPointerType
    Text
"pen"   -> PointerType -> Parser PointerType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PointerType
PenPointerType
    Text
x       -> PointerType -> Parser PointerType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MisoString -> PointerType
UnknownPointerType (Text -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Text
x))
-----------------------------------------------------------------------------
-- | Options for handling event propagation.
data Options
  = Options
  { Options -> Bool
_preventDefault :: Bool
  , Options -> Bool
_stopPropagation :: Bool
  } deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Options -> ShowS
showsPrec :: Int -> Options -> ShowS
$cshow :: Options -> String
show :: Options -> String
$cshowList :: [Options] -> ShowS
showList :: [Options] -> ShowS
Show, Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
/= :: Options -> Options -> Bool
Eq, (forall x. Options -> Rep Options x)
-> (forall x. Rep Options x -> Options) -> Generic Options
forall x. Rep Options x -> Options
forall x. Options -> Rep Options x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Options -> Rep Options x
from :: forall x. Options -> Rep Options x
$cto :: forall x. Rep Options x -> Options
to :: forall x. Rep Options x -> Options
Generic)
-----------------------------------------------------------------------------
instance Monoid Options where
  mempty :: Options
mempty = Options
defaultOptions
-----------------------------------------------------------------------------
instance Semigroup Options where
  Options Bool
p1 Bool
s1 <> :: Options -> Options -> Options
<> Options Bool
p2 Bool
s2 = Bool -> Bool -> Options
Options (Bool
p1 Bool -> Bool -> Bool
|| Bool
p2) (Bool
s1 Bool -> Bool -> Bool
|| Bool
s2)
-----------------------------------------------------------------------------
-- | Smart constructor for specifying 'preventDefault'
--
-- @since 1.9.0.0
preventDefault :: Options
preventDefault :: Options
preventDefault = Options
defaultOptions { _preventDefault = True }
-----------------------------------------------------------------------------
-- | Smart constructor for specifying 'stopPropagation'
--
-- @since 1.9.0.0
stopPropagation :: Options
stopPropagation :: Options
stopPropagation = Options
defaultOptions { _stopPropagation = True }
-----------------------------------------------------------------------------
instance ToJSVal Options where
  toJSVal :: Options -> JSM JSVal
toJSVal Options {Bool
_preventDefault :: Options -> Bool
_stopPropagation :: Options -> Bool
_preventDefault :: Bool
_stopPropagation :: Bool
..} = do
    o <- JSM Object
create
    FFI.set "preventDefault" _preventDefault o
    FFI.set "stopPropagation" _stopPropagation o
    toJSVal o
-----------------------------------------------------------------------------
-- | Default value for 'Options'.
--
-- > defaultOptions = Options { preventDefault = False, stopPropagation = False }
defaultOptions :: Options
defaultOptions :: Options
defaultOptions
  = Options
  { _preventDefault :: Bool
_preventDefault = Bool
False
  , _stopPropagation :: Bool
_stopPropagation = Bool
False
  }
-----------------------------------------------------------------------------
-- | Convenience type for Events
type Events = M.Map MisoString Capture
-----------------------------------------------------------------------------
-- | Capture
--
-- Used to determine if *capture* should be set when using /addEventListener/
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/EventTarget/addEventListener#capture>
--
type Capture = Bool
-----------------------------------------------------------------------------
-- | Default delegated events
defaultEvents :: Events
defaultEvents :: Events
defaultEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"blur", Bool
True)
  , (MisoString
"change", Bool
False)
  , (MisoString
"click", Bool
False)
  , (MisoString
"contextmenu", Bool
False)
  , (MisoString
"dblclick", Bool
False)
  , (MisoString
"focus", Bool
False)
  , (MisoString
"input", Bool
False)
  , (MisoString
"select", Bool
False)
  , (MisoString
"submit", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Keyboard events
keyboardEvents :: Events
keyboardEvents :: Events
keyboardEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"keydown", Bool
False)
  , (MisoString
"keypress", Bool
False)
  , (MisoString
"keyup", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Mouse events
mouseEvents :: Events
mouseEvents :: Events
mouseEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"mouseup", Bool
False)
  , (MisoString
"mousedown", Bool
False)
  , (MisoString
"mouseenter", Bool
True)
  , (MisoString
"mouseleave", Bool
False)
  , (MisoString
"mouseover", Bool
False)
  , (MisoString
"mouseout", Bool
False)
  , (MisoString
"contextmenu", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Drag events
dragEvents :: Events
dragEvents :: Events
dragEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"dragstart", Bool
False)
  , (MisoString
"dragover", Bool
False)
  , (MisoString
"dragend", Bool
False)
  , (MisoString
"dragenter", Bool
False)
  , (MisoString
"dragleave", Bool
False)
  , (MisoString
"drag", Bool
False)
  , (MisoString
"drop", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Pointer events
pointerEvents :: Events
pointerEvents :: Events
pointerEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"pointerup", Bool
False)
  , (MisoString
"pointerdown", Bool
False)
  , (MisoString
"pointerenter", Bool
True)
  , (MisoString
"pointercancel", Bool
False)
  , (MisoString
"pointerleave", Bool
False)
  , (MisoString
"pointerover", Bool
False)
  , (MisoString
"pointerout", Bool
False)
  , (MisoString
"contextmenu", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Audio video events
-- For use with the /<audio/> and /<video/> tags.
mediaEvents :: Events
mediaEvents :: Events
mediaEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"abort", Bool
True)
  , (MisoString
"canplay", Bool
True)
  , (MisoString
"canplaythrough", Bool
True)
  , (MisoString
"durationchange", Bool
False)
  , (MisoString
"emptied", Bool
True)
  , (MisoString
"ended", Bool
True)
  , (MisoString
"error", Bool
True)
  , (MisoString
"loadeddata", Bool
False)
  , (MisoString
"loadedmetadata", Bool
False)
  , (MisoString
"loadstart", Bool
False)
  , (MisoString
"pause", Bool
True)
  , (MisoString
"play", Bool
True)
  , (MisoString
"playing", Bool
True)
  , (MisoString
"progress", Bool
True)
  , (MisoString
"ratechange", Bool
True)
  , (MisoString
"seeked", Bool
True)
  , (MisoString
"seeking", Bool
True)
  , (MisoString
"stalled", Bool
True)
  , (MisoString
"suspend", Bool
True)
  , (MisoString
"timeupdate", Bool
True)
  , (MisoString
"volumechange", Bool
True)
  , (MisoString
"waiting", Bool
True)
  ]
-----------------------------------------------------------------------------
-- | Clipboard events
clipboardEvents :: Events
clipboardEvents :: Events
clipboardEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"cut", Bool
False)
  , (MisoString
"copy", Bool
False)
  , (MisoString
"paste", Bool
False)
  ]
-----------------------------------------------------------------------------
-- | Touch events
touchEvents :: Events
touchEvents :: Events
touchEvents = [(MisoString, Bool)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (MisoString
"touchstart", Bool
False)
  , (MisoString
"touchcancel", Bool
False)
  , (MisoString
"touchmove", Bool
False)
  , (MisoString
"touchend", Bool
False)
  ]
-----------------------------------------------------------------------------