-----------------------------------------------------------------------------
{-# LANGUAGE CPP               #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Event.Decoder
-- 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.Decoder
  ( -- ** Types
    Decoder (..)
  , DecodeTarget (..)
    -- ** Combinators
  , at
    -- ** Decoders
  , emptyDecoder
  , keycodeDecoder
  , keyInfoDecoder
  , checkedDecoder
  , valueDecoder
  , pointerDecoder
  ) where
-----------------------------------------------------------------------------
import Control.Applicative
import Data.Aeson.Types
#ifdef GHCJS_OLD
import GHCJS.Marshal (ToJSVal(toJSVal))
#else
import Language.Javascript.JSaddle (ToJSVal(toJSVal))
#endif
-----------------------------------------------------------------------------
import Miso.Event.Types
import Miso.String
-----------------------------------------------------------------------------
-- | Data type representing path (consisting of field names) within event object
-- where a decoder should be applied.
data DecodeTarget
  = DecodeTarget [MisoString]
  -- ^ Specify single path within Event object, where a decoder should be applied.
  | DecodeTargets [[MisoString]]
  -- ^ Specify multiple paths withing Event object, where decoding should be attempted. The first path where decoding suceeds is the one taken.
-----------------------------------------------------------------------------
-- | `ToJSVal` instance for `Decoder`
instance ToJSVal DecodeTarget where
  toJSVal :: DecodeTarget -> JSM JSVal
toJSVal (DecodeTarget [MisoString]
xs) = [MisoString] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal [MisoString]
xs
  toJSVal (DecodeTargets [[MisoString]]
xs) = [[MisoString]] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal [[MisoString]]
xs
-----------------------------------------------------------------------------
-- | Decoder data type for parsing events
data Decoder a
  = Decoder
  { forall a. Decoder a -> Value -> Parser a
decoder :: Value -> Parser a
    -- ^ FromJSON-based Event decoder
  , forall a. Decoder a -> DecodeTarget
decodeAt :: DecodeTarget
    -- ^ Location in DOM of where to decode
  }
-----------------------------------------------------------------------------
-- | Smart constructor for building a `Decoder`.
at :: [MisoString] -> (Value -> Parser a) -> Decoder a
at :: forall a. [MisoString] -> (Value -> Parser a) -> Decoder a
at [MisoString]
decodeAt Value -> Parser a
decoder = Decoder {decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
decodeAt, Value -> Parser a
decoder :: Value -> Parser a
decoder :: Value -> Parser a
..}
-----------------------------------------------------------------------------
-- | Empty decoder for use with events like "click" that do not
-- return any meaningful values
emptyDecoder :: Decoder ()
emptyDecoder :: Decoder ()
emptyDecoder = [MisoString]
forall a. Monoid a => a
mempty [MisoString] -> (Value -> Parser ()) -> Decoder ()
forall a. [MisoString] -> (Value -> Parser a) -> Decoder a
`at` Value -> Parser ()
go
  where
    go :: Value -> Parser ()
go = String -> (Object -> Parser ()) -> Value -> Parser ()
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"emptyDecoder" ((Object -> Parser ()) -> Value -> Parser ())
-> (Object -> Parser ()) -> Value -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Object
_ -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-----------------------------------------------------------------------------
-- | Retrieves either "keyCode", "which" or "charCode" field in `Decoder`
keycodeDecoder :: Decoder KeyCode
keycodeDecoder :: Decoder KeyCode
keycodeDecoder = Decoder {DecodeTarget
Value -> Parser KeyCode
decoder :: Value -> Parser KeyCode
decodeAt :: DecodeTarget
decodeAt :: DecodeTarget
decoder :: Value -> Parser KeyCode
..}
  where
    decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    decoder :: Value -> Parser KeyCode
decoder = String -> (Object -> Parser KeyCode) -> Value -> Parser KeyCode
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"event" ((Object -> Parser KeyCode) -> Value -> Parser KeyCode)
-> (Object -> Parser KeyCode) -> Value -> Parser KeyCode
forall a b. (a -> b) -> a -> b
$ \Object
o ->
       Int -> KeyCode
KeyCode (Int -> KeyCode) -> Parser Int -> Parser KeyCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keyCode" Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"which" Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"charCode")
-----------------------------------------------------------------------------
-- | Retrieves either "keyCode", "which" or "charCode" field in `Decoder`,
-- along with shift, ctrl, meta and alt.
keyInfoDecoder :: Decoder KeyInfo
keyInfoDecoder :: Decoder KeyInfo
keyInfoDecoder = Decoder {DecodeTarget
Value -> Parser KeyInfo
decoder :: Value -> Parser KeyInfo
decodeAt :: DecodeTarget
decodeAt :: DecodeTarget
decoder :: Value -> Parser KeyInfo
..}
  where
    decodeAt :: DecodeTarget
decodeAt =
      [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    decoder :: Value -> Parser KeyInfo
decoder =
      String -> (Object -> Parser KeyInfo) -> Value -> Parser KeyInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"event" ((Object -> Parser KeyInfo) -> Value -> Parser KeyInfo)
-> (Object -> Parser KeyInfo) -> Value -> Parser KeyInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        KeyCode -> Bool -> Bool -> Bool -> Bool -> KeyInfo
KeyInfo
          (KeyCode -> Bool -> Bool -> Bool -> Bool -> KeyInfo)
-> Parser KeyCode
-> Parser (Bool -> Bool -> Bool -> Bool -> KeyInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser KeyCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keyCode" Parser KeyCode -> Parser KeyCode -> Parser KeyCode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser KeyCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"which" Parser KeyCode -> Parser KeyCode -> Parser KeyCode
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser KeyCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"charCode")
          Parser (Bool -> Bool -> Bool -> Bool -> KeyInfo)
-> Parser Bool -> Parser (Bool -> Bool -> Bool -> KeyInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"shiftKey"
          Parser (Bool -> Bool -> Bool -> KeyInfo)
-> Parser Bool -> Parser (Bool -> Bool -> KeyInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"metaKey"
          Parser (Bool -> Bool -> KeyInfo)
-> Parser Bool -> Parser (Bool -> KeyInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ctrlKey"
          Parser (Bool -> KeyInfo) -> Parser Bool -> Parser KeyInfo
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"altKey"
-----------------------------------------------------------------------------
-- | Retrieves "value" field in `Decoder`
valueDecoder :: Decoder MisoString
valueDecoder :: Decoder MisoString
valueDecoder = Decoder {DecodeTarget
Value -> Parser MisoString
decoder :: Value -> Parser MisoString
decodeAt :: DecodeTarget
decodeAt :: DecodeTarget
decoder :: Value -> Parser MisoString
..}
  where
    decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString
"target"]
    decoder :: Value -> Parser MisoString
decoder = String
-> (Object -> Parser MisoString) -> Value -> Parser MisoString
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"target" ((Object -> Parser MisoString) -> Value -> Parser MisoString)
-> (Object -> Parser MisoString) -> Value -> Parser MisoString
forall a b. (a -> b) -> a -> b
$ \Object
o -> Object
o Object -> Key -> Parser MisoString
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
-----------------------------------------------------------------------------
-- | Retrieves "checked" field in Decoder
checkedDecoder :: Decoder Checked
checkedDecoder :: Decoder Checked
checkedDecoder = Decoder {DecodeTarget
Value -> Parser Checked
decoder :: Value -> Parser Checked
decodeAt :: DecodeTarget
decodeAt :: DecodeTarget
decoder :: Value -> Parser Checked
..}
  where
    decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString
"target"]
    decoder :: Value -> Parser Checked
decoder = String -> (Object -> Parser Checked) -> Value -> Parser Checked
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"target" ((Object -> Parser Checked) -> Value -> Parser Checked)
-> (Object -> Parser Checked) -> Value -> Parser Checked
forall a b. (a -> b) -> a -> b
$ \Object
o ->
      Bool -> Checked
Checked (Bool -> Checked) -> Parser Bool -> Parser Checked
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"checked")
-----------------------------------------------------------------------------
-- | Pointer decoder for use with events like "onpointerover"
pointerDecoder :: Decoder PointerEvent
pointerDecoder :: Decoder PointerEvent
pointerDecoder = Decoder {DecodeTarget
Value -> Parser PointerEvent
decoder :: Value -> Parser PointerEvent
decodeAt :: DecodeTarget
decodeAt :: DecodeTarget
decoder :: Value -> Parser PointerEvent
..}
  where
    pair :: Object -> Key -> Key -> Parser (a, b)
pair Object
o Key
x Key
y = (a -> b -> (a, b)) -> Parser a -> Parser b -> Parser (a, b)
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
x) (Object
o Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
y)
    decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    decoder :: Value -> Parser PointerEvent
decoder = String
-> (Object -> Parser PointerEvent) -> Value -> Parser PointerEvent
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"pointerDecoder" ((Object -> Parser PointerEvent) -> Value -> Parser PointerEvent)
-> (Object -> Parser PointerEvent) -> Value -> Parser PointerEvent
forall a b. (a -> b) -> a -> b
$ \Object
o ->
      PointerType
-> Int
-> Bool
-> (Double, Double)
-> (Double, Double)
-> (Double, Double)
-> (Double, Double)
-> Double
-> PointerEvent
PointerEvent
        (PointerType
 -> Int
 -> Bool
 -> (Double, Double)
 -> (Double, Double)
 -> (Double, Double)
 -> (Double, Double)
 -> Double
 -> PointerEvent)
-> Parser PointerType
-> Parser
     (Int
      -> Bool
      -> (Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> Double
      -> PointerEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser PointerType
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pointerType"
        Parser
  (Int
   -> Bool
   -> (Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> Double
   -> PointerEvent)
-> Parser Int
-> Parser
     (Bool
      -> (Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> Double
      -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pointerId"
        Parser
  (Bool
   -> (Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> Double
   -> PointerEvent)
-> Parser Bool
-> Parser
     ((Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> (Double, Double)
      -> Double
      -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"isPrimary"
        Parser
  ((Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> (Double, Double)
   -> Double
   -> PointerEvent)
-> Parser (Double, Double)
-> Parser
     ((Double, Double)
      -> (Double, Double) -> (Double, Double) -> Double -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Key -> Key -> Parser (Double, Double)
forall {a} {b}.
(FromJSON a, FromJSON b) =>
Object -> Key -> Key -> Parser (a, b)
pair Object
o Key
"clientX" Key
"clientY"
        Parser
  ((Double, Double)
   -> (Double, Double) -> (Double, Double) -> Double -> PointerEvent)
-> Parser (Double, Double)
-> Parser
     ((Double, Double) -> (Double, Double) -> Double -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Key -> Key -> Parser (Double, Double)
forall {a} {b}.
(FromJSON a, FromJSON b) =>
Object -> Key -> Key -> Parser (a, b)
pair Object
o Key
"screenX" Key
"screenY"
        Parser
  ((Double, Double) -> (Double, Double) -> Double -> PointerEvent)
-> Parser (Double, Double)
-> Parser ((Double, Double) -> Double -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Key -> Key -> Parser (Double, Double)
forall {a} {b}.
(FromJSON a, FromJSON b) =>
Object -> Key -> Key -> Parser (a, b)
pair Object
o Key
"pageX" Key
"pageY"
        Parser ((Double, Double) -> Double -> PointerEvent)
-> Parser (Double, Double) -> Parser (Double -> PointerEvent)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Key -> Key -> Parser (Double, Double)
forall {a} {b}.
(FromJSON a, FromJSON b) =>
Object -> Key -> Key -> Parser (a, b)
pair Object
o Key
"tiltX" Key
"tiltY"
        Parser (Double -> PointerEvent)
-> Parser Double -> Parser PointerEvent
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Double
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pressure"
-----------------------------------------------------------------------------