{-|
Module      : Monomer.Event.Types
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Basic types for Monomer events.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}

module Monomer.Event.Types where

import Data.Default
import Data.Text (Text)
import Data.Typeable (Typeable, cast, typeOf)
import Data.Map.Strict (Map)

import qualified Data.Map.Strict as M

import Monomer.Common

-- | Keycode for keyboard events. Used instead of Scancodes to avoid mappings.
newtype KeyCode
  = KeyCode { KeyCode -> Int
unKeyCode :: Int }
  deriving (KeyCode -> KeyCode -> Bool
(KeyCode -> KeyCode -> Bool)
-> (KeyCode -> KeyCode -> Bool) -> Eq KeyCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyCode -> KeyCode -> Bool
$c/= :: KeyCode -> KeyCode -> Bool
== :: KeyCode -> KeyCode -> Bool
$c== :: 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
min :: KeyCode -> KeyCode -> KeyCode
$cmin :: KeyCode -> KeyCode -> KeyCode
max :: KeyCode -> KeyCode -> KeyCode
$cmax :: KeyCode -> KeyCode -> KeyCode
>= :: KeyCode -> KeyCode -> Bool
$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
compare :: KeyCode -> KeyCode -> Ordering
$ccompare :: KeyCode -> KeyCode -> Ordering
$cp1Ord :: Eq KeyCode
Ord, 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
showList :: [KeyCode] -> ShowS
$cshowList :: [KeyCode] -> ShowS
show :: KeyCode -> String
$cshow :: KeyCode -> String
showsPrec :: Int -> KeyCode -> ShowS
$cshowsPrec :: Int -> KeyCode -> ShowS
Show)

-- | Status of a keyboard key.
data KeyStatus
  = KeyPressed
  | KeyReleased
  deriving (KeyStatus -> KeyStatus -> Bool
(KeyStatus -> KeyStatus -> Bool)
-> (KeyStatus -> KeyStatus -> Bool) -> Eq KeyStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyStatus -> KeyStatus -> Bool
$c/= :: KeyStatus -> KeyStatus -> Bool
== :: KeyStatus -> KeyStatus -> Bool
$c== :: KeyStatus -> KeyStatus -> Bool
Eq, Int -> KeyStatus -> ShowS
[KeyStatus] -> ShowS
KeyStatus -> String
(Int -> KeyStatus -> ShowS)
-> (KeyStatus -> String)
-> ([KeyStatus] -> ShowS)
-> Show KeyStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyStatus] -> ShowS
$cshowList :: [KeyStatus] -> ShowS
show :: KeyStatus -> String
$cshow :: KeyStatus -> String
showsPrec :: Int -> KeyStatus -> ShowS
$cshowsPrec :: Int -> KeyStatus -> ShowS
Show)

-- | Button of a pointer device (mouse).
data Button
  = BtnLeft
  | BtnMiddle
  | BtnRight
  deriving (Button -> Button -> Bool
(Button -> Button -> Bool)
-> (Button -> Button -> Bool) -> Eq Button
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Button -> Button -> Bool
$c/= :: Button -> Button -> Bool
== :: Button -> Button -> Bool
$c== :: Button -> Button -> Bool
Eq, Int -> Button -> ShowS
[Button] -> ShowS
Button -> String
(Int -> Button -> ShowS)
-> (Button -> String) -> ([Button] -> ShowS) -> Show Button
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Button] -> ShowS
$cshowList :: [Button] -> ShowS
show :: Button -> String
$cshow :: Button -> String
showsPrec :: Int -> Button -> ShowS
$cshowsPrec :: Int -> Button -> ShowS
Show, Eq Button
Eq Button
-> (Button -> Button -> Ordering)
-> (Button -> Button -> Bool)
-> (Button -> Button -> Bool)
-> (Button -> Button -> Bool)
-> (Button -> Button -> Bool)
-> (Button -> Button -> Button)
-> (Button -> Button -> Button)
-> Ord Button
Button -> Button -> Bool
Button -> Button -> Ordering
Button -> Button -> Button
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
min :: Button -> Button -> Button
$cmin :: Button -> Button -> Button
max :: Button -> Button -> Button
$cmax :: Button -> Button -> Button
>= :: Button -> Button -> Bool
$c>= :: Button -> Button -> Bool
> :: Button -> Button -> Bool
$c> :: Button -> Button -> Bool
<= :: Button -> Button -> Bool
$c<= :: Button -> Button -> Bool
< :: Button -> Button -> Bool
$c< :: Button -> Button -> Bool
compare :: Button -> Button -> Ordering
$ccompare :: Button -> Button -> Ordering
$cp1Ord :: Eq Button
Ord)

-- | Status of a mouse button.
data ButtonState
  = BtnPressed
  | BtnReleased
  deriving (ButtonState -> ButtonState -> Bool
(ButtonState -> ButtonState -> Bool)
-> (ButtonState -> ButtonState -> Bool) -> Eq ButtonState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ButtonState -> ButtonState -> Bool
$c/= :: ButtonState -> ButtonState -> Bool
== :: ButtonState -> ButtonState -> Bool
$c== :: ButtonState -> ButtonState -> Bool
Eq, Int -> ButtonState -> ShowS
[ButtonState] -> ShowS
ButtonState -> String
(Int -> ButtonState -> ShowS)
-> (ButtonState -> String)
-> ([ButtonState] -> ShowS)
-> Show ButtonState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ButtonState] -> ShowS
$cshowList :: [ButtonState] -> ShowS
show :: ButtonState -> String
$cshow :: ButtonState -> String
showsPrec :: Int -> ButtonState -> ShowS
$cshowsPrec :: Int -> ButtonState -> ShowS
Show)

-- | Movement direction in which wheel values are positive.
data WheelDirection
  = WheelNormal
  | WheelFlipped
  deriving (WheelDirection -> WheelDirection -> Bool
(WheelDirection -> WheelDirection -> Bool)
-> (WheelDirection -> WheelDirection -> Bool) -> Eq WheelDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WheelDirection -> WheelDirection -> Bool
$c/= :: WheelDirection -> WheelDirection -> Bool
== :: WheelDirection -> WheelDirection -> Bool
$c== :: WheelDirection -> WheelDirection -> Bool
Eq, Int -> WheelDirection -> ShowS
[WheelDirection] -> ShowS
WheelDirection -> String
(Int -> WheelDirection -> ShowS)
-> (WheelDirection -> String)
-> ([WheelDirection] -> ShowS)
-> Show WheelDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WheelDirection] -> ShowS
$cshowList :: [WheelDirection] -> ShowS
show :: WheelDirection -> String
$cshow :: WheelDirection -> String
showsPrec :: Int -> WheelDirection -> ShowS
$cshowsPrec :: Int -> WheelDirection -> ShowS
Show)

-- | Types of clipboard content.
data ClipboardData
  = ClipboardEmpty
  | ClipboardText Text
  deriving (ClipboardData -> ClipboardData -> Bool
(ClipboardData -> ClipboardData -> Bool)
-> (ClipboardData -> ClipboardData -> Bool) -> Eq ClipboardData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClipboardData -> ClipboardData -> Bool
$c/= :: ClipboardData -> ClipboardData -> Bool
== :: ClipboardData -> ClipboardData -> Bool
$c== :: ClipboardData -> ClipboardData -> Bool
Eq, Int -> ClipboardData -> ShowS
[ClipboardData] -> ShowS
ClipboardData -> String
(Int -> ClipboardData -> ShowS)
-> (ClipboardData -> String)
-> ([ClipboardData] -> ShowS)
-> Show ClipboardData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClipboardData] -> ShowS
$cshowList :: [ClipboardData] -> ShowS
show :: ClipboardData -> String
$cshow :: ClipboardData -> String
showsPrec :: Int -> ClipboardData -> ShowS
$cshowsPrec :: Int -> ClipboardData -> ShowS
Show)

-- | Constraints for drag event messages.
type DragMsg i = (Eq i, Typeable i)

-- | Drag message container.
data WidgetDragMsg
  = forall i . DragMsg i => WidgetDragMsg i

instance Eq WidgetDragMsg where
  WidgetDragMsg i
d1 == :: WidgetDragMsg -> WidgetDragMsg -> Bool
== WidgetDragMsg i
d2 = case i -> Maybe i
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast i
d1 of
    Just i
d -> i
d i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
d2
    Maybe i
_ -> Bool
False

instance Show WidgetDragMsg where
  show :: WidgetDragMsg -> String
show (WidgetDragMsg i
info) = String
"WidgetDragMsg: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (i -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf i
info)

-- | Supported Monomer SystemEvents
data SystemEvent
  {-|
  Click (press and release) of a mouse button. Includes mouse position and click
  count.
  -}
  = Click Point Button Int
  {-|
  Click or release of a mouse button. Includes times pressed/released and mouse
  position.
  -}
  | ButtonAction Point Button ButtonState Int
  -- | Mouse wheel movement. Includes mouse position, move size in both axes and
  --   wheel direction.
  | WheelScroll Point Point WheelDirection
  -- | Keyboard key action. Includes modifiers, keyCode and pressed/released.
  --   This event should not be used for text input.
  | KeyAction KeyMod KeyCode KeyStatus
  -- | Processed keyboard events. Some Unicode characters require several key
  --   presses to produce the result. This event provides the final result.
  | TextInput Text
  -- | Provides current clipboard contents to a requesting widget.
  | Clipboard ClipboardData
  -- | Target now has focus. Includes path of the previously focused widget.
  | Focus Path
  -- | Target has lost focus. Includes path of the next focused widget.
  | Blur Path
  -- | Mouse has entered the assigned viewport.
  | Enter Point
  -- | Mouse has moved inside the assigned viewport. This event keeps being
  --   received if the main mouse button is pressed, even if the mouse is
  --   outside the assigned bounds or even the window.
  | Move Point
  -- | Mouse has left the assigned viewport. This event is not received until
  --   the main mouse button has been pressed.
  | Leave Point
  -- | A drag action is active and the mouse is inside the current viewport. The
  --   messsage can be used to decide if it applies to the current widget. This
  --   event is not received by the widget which initiated the drag action, even
  --   if dragging over it.
  | Drag Point Path WidgetDragMsg
  -- | A drag action was active and the main button was released inside the
  --   current viewport.
  | Drop Point Path WidgetDragMsg
  deriving (SystemEvent -> SystemEvent -> Bool
(SystemEvent -> SystemEvent -> Bool)
-> (SystemEvent -> SystemEvent -> Bool) -> Eq SystemEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SystemEvent -> SystemEvent -> Bool
$c/= :: SystemEvent -> SystemEvent -> Bool
== :: SystemEvent -> SystemEvent -> Bool
$c== :: SystemEvent -> SystemEvent -> Bool
Eq, Int -> SystemEvent -> ShowS
[SystemEvent] -> ShowS
SystemEvent -> String
(Int -> SystemEvent -> ShowS)
-> (SystemEvent -> String)
-> ([SystemEvent] -> ShowS)
-> Show SystemEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SystemEvent] -> ShowS
$cshowList :: [SystemEvent] -> ShowS
show :: SystemEvent -> String
$cshow :: SystemEvent -> String
showsPrec :: Int -> SystemEvent -> ShowS
$cshowsPrec :: Int -> SystemEvent -> ShowS
Show)

-- | Status of input devices.
data InputStatus = InputStatus {
  -- | Mouse position.
  InputStatus -> Point
_ipsMousePos :: Point,
  -- | Previous mouse position.
  InputStatus -> Point
_ipsMousePosPrev :: Point,
  -- | Current key modifiers (shift, ctrl, alt, etc).
  InputStatus -> KeyMod
_ipsKeyMod :: KeyMod,
  -- | Current status of keyCodes. If not in the map, status is KeyReleased.
  InputStatus -> Map KeyCode KeyStatus
_ipsKeys :: Map KeyCode KeyStatus,
  -- | Status of mouse buttons. If not in the map, status is BtnReleased.
  InputStatus -> Map Button ButtonState
_ipsButtons :: Map Button ButtonState
} deriving (InputStatus -> InputStatus -> Bool
(InputStatus -> InputStatus -> Bool)
-> (InputStatus -> InputStatus -> Bool) -> Eq InputStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputStatus -> InputStatus -> Bool
$c/= :: InputStatus -> InputStatus -> Bool
== :: InputStatus -> InputStatus -> Bool
$c== :: InputStatus -> InputStatus -> Bool
Eq, Int -> InputStatus -> ShowS
[InputStatus] -> ShowS
InputStatus -> String
(Int -> InputStatus -> ShowS)
-> (InputStatus -> String)
-> ([InputStatus] -> ShowS)
-> Show InputStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputStatus] -> ShowS
$cshowList :: [InputStatus] -> ShowS
show :: InputStatus -> String
$cshow :: InputStatus -> String
showsPrec :: Int -> InputStatus -> ShowS
$cshowsPrec :: Int -> InputStatus -> ShowS
Show)

instance Default InputStatus where
  def :: InputStatus
def = InputStatus :: Point
-> Point
-> KeyMod
-> Map KeyCode KeyStatus
-> Map Button ButtonState
-> InputStatus
InputStatus {
    _ipsMousePos :: Point
_ipsMousePos = Double -> Double -> Point
Point (-Double
1) (-Double
1),
    _ipsMousePosPrev :: Point
_ipsMousePosPrev = Double -> Double -> Point
Point (-Double
1) (-Double
1),
    _ipsKeyMod :: KeyMod
_ipsKeyMod = KeyMod
forall a. Default a => a
def,
    _ipsKeys :: Map KeyCode KeyStatus
_ipsKeys = Map KeyCode KeyStatus
forall k a. Map k a
M.empty,
    _ipsButtons :: Map Button ButtonState
_ipsButtons = Map Button ButtonState
forall k a. Map k a
M.empty
  }

{-|
Keyboard modifiers. True indicates the key is pressed.

Note: The __fn__ function in Macs cannot be detected individually.
-}
data KeyMod = KeyMod {
  KeyMod -> Bool
_kmLeftShift :: Bool,
  KeyMod -> Bool
_kmRightShift :: Bool,
  KeyMod -> Bool
_kmLeftCtrl :: Bool,
  KeyMod -> Bool
_kmRightCtrl :: Bool,
  KeyMod -> Bool
_kmLeftAlt :: Bool,
  KeyMod -> Bool
_kmRightAlt :: Bool,
  KeyMod -> Bool
_kmLeftGUI :: Bool,
  KeyMod -> Bool
_kmRightGUI :: Bool,
  KeyMod -> Bool
_kmNumLock :: Bool,
  KeyMod -> Bool
_kmCapsLock :: Bool,
  KeyMod -> Bool
_kmAltGr :: Bool
} deriving (KeyMod -> KeyMod -> Bool
(KeyMod -> KeyMod -> Bool)
-> (KeyMod -> KeyMod -> Bool) -> Eq KeyMod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyMod -> KeyMod -> Bool
$c/= :: KeyMod -> KeyMod -> Bool
== :: KeyMod -> KeyMod -> Bool
$c== :: KeyMod -> KeyMod -> Bool
Eq, Int -> KeyMod -> ShowS
[KeyMod] -> ShowS
KeyMod -> String
(Int -> KeyMod -> ShowS)
-> (KeyMod -> String) -> ([KeyMod] -> ShowS) -> Show KeyMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyMod] -> ShowS
$cshowList :: [KeyMod] -> ShowS
show :: KeyMod -> String
$cshow :: KeyMod -> String
showsPrec :: Int -> KeyMod -> ShowS
$cshowsPrec :: Int -> KeyMod -> ShowS
Show)

instance Default KeyMod where
  def :: KeyMod
def = KeyMod :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> KeyMod
KeyMod {
    _kmLeftShift :: Bool
_kmLeftShift = Bool
False,
    _kmRightShift :: Bool
_kmRightShift = Bool
False,
    _kmLeftCtrl :: Bool
_kmLeftCtrl = Bool
False,
    _kmRightCtrl :: Bool
_kmRightCtrl = Bool
False,
    _kmLeftAlt :: Bool
_kmLeftAlt = Bool
False,
    _kmRightAlt :: Bool
_kmRightAlt = Bool
False,
    _kmLeftGUI :: Bool
_kmLeftGUI = Bool
False,
    _kmRightGUI :: Bool
_kmRightGUI = Bool
False,
    _kmNumLock :: Bool
_kmNumLock = Bool
False,
    _kmCapsLock :: Bool
_kmCapsLock = Bool
False,
    _kmAltGr :: Bool
_kmAltGr = Bool
False
  }