{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.Blank.Events where

import Control.Applicative
import Control.Concurrent.STM

import Data.Aeson (FromJSON(..), Value(..), ToJSON(..))
import Data.Aeson.Types ((.:), (.=), object)
import Data.Text (Text)

import TextShow.TH (deriveTextShow)

-- | 'EventName' mirrors event names from jQuery, and uses lowercase.
-- Possible named events
-- 
-- * @keypress@, @keydown@, @keyup@
-- * @mouseDown@, @mouseenter@, @mousemove@, @mouseout@, @mouseover@, @mouseup@
type EventName = Text

-- | 'EventQueue' is an STM channel ('TChan') of 'Event's.
-- Intentionally, 'EventQueue' is not abstract.
type EventQueue = TChan Event

-- | Basic event from browser. See <http://api.jquery.com/category/events/> for details.
data Event = Event
        { Event -> Bool
eMetaKey :: Bool
        , Event -> Maybe (Double, Double)
ePageXY  :: Maybe (Double, Double)
        , Event -> EventName
eType    :: EventName          -- "Describes the nature of the event." jquery
        , Event -> Maybe Int
eWhich   :: Maybe Int          -- magic code for key presses
        }
        deriving (Event -> Event -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, Eq Event
Event -> Event -> Bool
Event -> Event -> Ordering
Event -> Event -> Event
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 :: Event -> Event -> Event
$cmin :: Event -> Event -> Event
max :: Event -> Event -> Event
$cmax :: Event -> Event -> Event
>= :: Event -> Event -> Bool
$c>= :: Event -> Event -> Bool
> :: Event -> Event -> Bool
$c> :: Event -> Event -> Bool
<= :: Event -> Event -> Bool
$c<= :: Event -> Event -> Bool
< :: Event -> Event -> Bool
$c< :: Event -> Event -> Bool
compare :: Event -> Event -> Ordering
$ccompare :: Event -> Event -> Ordering
Ord, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)
$(deriveTextShow ''Event)

instance FromJSON Event where
   parseJSON :: Value -> Parser Event
parseJSON (Object Object
v) = Bool -> Maybe (Double, Double) -> EventName -> Maybe Int -> Event
Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"metaKey")              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pageXY")      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type")
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"which")       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
   parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse of Event"    

instance ToJSON Event where
   toJSON :: Event -> Value
toJSON Event
e = [Pair] -> Value
object 
            forall a b. (a -> b) -> a -> b
$ ((:) (Key
"metaKey" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=  Event -> Bool
eMetaKey Event
e))
            forall a b. (a -> b) -> a -> b
$ (case Event -> Maybe (Double, Double)
ePageXY Event
e of
                 Maybe (Double, Double)
Nothing -> forall a. a -> a
id
                 Just (Double
x,Double
y) -> (:) (Key
"pageXY" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Double
x,Double
y)))
            forall a b. (a -> b) -> a -> b
$ ((:) (Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Event -> EventName
eType Event
e))
            forall a b. (a -> b) -> a -> b
$ (case Event -> Maybe Int
eWhich Event
e of
                 Maybe Int
Nothing -> forall a. a -> a
id
                 Just Int
w -> (:) (Key
"which" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
w))
            forall a b. (a -> b) -> a -> b
$ []