Types.hs

{-|
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 { unKeyCode :: Int }
  deriving (Eq, Ord, Show)

-- | Status of a keyboard key.
data KeyStatus
  = KeyPressed
  | KeyReleased
  deriving (Eq, Show)

-- | Button of a pointer device (mouse).
data Button
  = BtnLeft
  | BtnMiddle
  | BtnRight
  deriving (Eq, Show, Ord)

-- | Status of a mouse button.
data ButtonState
  = BtnPressed
  | BtnReleased
  deriving (Eq, Show)

-- | Movement direction in which wheel values are positive.
data WheelDirection
  = WheelNormal
  | WheelFlipped
  deriving (Eq, Show)

-- | Types of clipboard content.
data ClipboardData
  = ClipboardEmpty
  | ClipboardText Text
  deriving (Eq, 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 d1 == WidgetDragMsg d2 = case cast d1 of
    Just d -> d == d2
    _ -> False

instance Show WidgetDragMsg where
  show (WidgetDragMsg info) = "WidgetDragMsg: " ++ show (typeOf 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 (Eq, Show)

-- | Status of input devices.
data InputStatus = InputStatus {
  -- | Mouse position.
  _ipsMousePos :: Point,
  -- | Previous mouse position.
  _ipsMousePosPrev :: Point,
  -- | Current key modifiers (shift, ctrl, alt, etc).
  _ipsKeyMod :: KeyMod,
  -- | Current status of keyCodes. If not in the map, status is KeyReleased.
  _ipsKeys :: Map KeyCode KeyStatus,
  -- | Status of mouse buttons. If not in the map, status is BtnReleased.
  _ipsButtons :: Map Button ButtonState
} deriving (Eq, Show)

instance Default InputStatus where
  def = InputStatus {
    _ipsMousePos = Point (-1) (-1),
    _ipsMousePosPrev = Point (-1) (-1),
    _ipsKeyMod = def,
    _ipsKeys = M.empty,
    _ipsButtons = M.empty
  }

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

Note: The __fn__ function in Macs cannot be detected individually.
-}
data KeyMod = KeyMod {
  _kmLeftShift :: Bool,
  _kmRightShift :: Bool,
  _kmLeftCtrl :: Bool,
  _kmRightCtrl :: Bool,
  _kmLeftAlt :: Bool,
  _kmRightAlt :: Bool,
  _kmLeftGUI :: Bool,
  _kmRightGUI :: Bool,
  _kmNumLock :: Bool,
  _kmCapsLock :: Bool,
  _kmAltGr :: Bool
} deriving (Eq, Show)

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