module Graphics.Blank.Events
(
Event(..)
, NamedEvent(..)
, EventName(..)
, EventQueue
, writeEventQueue
, readEventQueue
, tryReadEventQueue
, newEventQueue
) where
import Data.Aeson (FromJSON(..), Value)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Char
import Control.Monad
import Control.Applicative((<|>))
import Control.Concurrent.STM
data Event = Event
{ jsCode :: Int
, jsMouse :: Maybe (Int,Int)
}
deriving (Show)
data NamedEvent = NamedEvent EventName Event
deriving (Show)
instance FromJSON NamedEvent where
parseJSON o = do
(str::String,_::Value,_::Value,_::Value) <- parseJSON o
case Map.lookup str namedEventDB of
Just n -> fmap (NamedEvent n) (opt1 <|> opt2)
Nothing -> fail "bad parse"
where
opt1 = do (_::String,code,x,y) <- parseJSON o
return $ Event code (Just (x,y))
opt2 = do (_::String,code,_::Value,_::Value) <- parseJSON o
return $ Event code Nothing
namedEventDB :: Map String EventName
namedEventDB = Map.fromList
[ (map toLower (show n),n)
| n <- [minBound..maxBound]
]
data EventName
= KeyPress
| KeyDown
| KeyUp
| MouseDown
| MouseEnter
| MouseMove
| MouseOut
| MouseOver
| MouseUp
deriving (Eq, Ord, Show, Enum, Bounded)
type EventQueue = TChan NamedEvent
writeEventQueue :: EventQueue -> NamedEvent -> IO ()
writeEventQueue q e = atomically $ writeTChan q e
readEventQueue :: EventQueue -> IO NamedEvent
readEventQueue q = atomically $ readTChan q
tryReadEventQueue :: EventQueue -> IO (Maybe NamedEvent)
tryReadEventQueue q = atomically $ do
b <- isEmptyTChan q
if b then return Nothing
else liftM Just (readTChan q)
newEventQueue :: IO EventQueue
newEventQueue = atomically newTChan