{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Miso.Subscription.Keyboard
(
Arrows (..)
, arrowsSub
, directionSub
, keyboardSub
, wasdSub
) where
import Control.Monad.IO.Class
import Data.IORef
import Data.Set
import qualified Data.Set as S
import GHCJS.Marshal
import JavaScript.Object
import JavaScript.Object.Internal
import Miso.Effect (Sub)
import Miso.FFI
data Arrows = Arrows {
Arrows -> Int
arrowX :: !Int
, Arrows -> Int
arrowY :: !Int
} deriving (Int -> Arrows -> ShowS
[Arrows] -> ShowS
Arrows -> String
(Int -> Arrows -> ShowS)
-> (Arrows -> String) -> ([Arrows] -> ShowS) -> Show Arrows
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arrows] -> ShowS
$cshowList :: [Arrows] -> ShowS
show :: Arrows -> String
$cshow :: Arrows -> String
showsPrec :: Int -> Arrows -> ShowS
$cshowsPrec :: Int -> Arrows -> ShowS
Show, Arrows -> Arrows -> Bool
(Arrows -> Arrows -> Bool)
-> (Arrows -> Arrows -> Bool) -> Eq Arrows
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arrows -> Arrows -> Bool
$c/= :: Arrows -> Arrows -> Bool
== :: Arrows -> Arrows -> Bool
$c== :: Arrows -> Arrows -> Bool
Eq)
toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows
toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows
toArrows ([Int]
up, [Int]
down, [Int]
left, [Int]
right) Set Int
set' =
Arrows :: Int -> Int -> Arrows
Arrows {
arrowX :: Int
arrowX =
case ([Int] -> Bool
check [Int]
left, [Int] -> Bool
check [Int]
right) of
(Bool
True, Bool
False) -> -Int
1
(Bool
False, Bool
True) -> Int
1
(Bool
_,Bool
_) -> Int
0
, arrowY :: Int
arrowY =
case ([Int] -> Bool
check [Int]
down, [Int] -> Bool
check [Int]
up) of
(Bool
True, Bool
False) -> -Int
1
(Bool
False, Bool
True) -> Int
1
(Bool
_,Bool
_) -> Int
0
}
where
check :: [Int] -> Bool
check = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Int
set')
arrowsSub :: (Arrows -> action) -> Sub action
arrowsSub :: (Arrows -> action) -> Sub action
arrowsSub = ([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
forall action.
([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
directionSub ([Int
38], [Int
40], [Int
37], [Int
39])
wasdSub :: (Arrows -> action) -> Sub action
wasdSub :: (Arrows -> action) -> Sub action
wasdSub = ([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
forall action.
([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
directionSub ([Int
87], [Int
83], [Int
65], [Int
68])
directionSub :: ([Int], [Int], [Int], [Int])
-> (Arrows -> action)
-> Sub action
directionSub :: ([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
directionSub ([Int], [Int], [Int], [Int])
dirs = (Set Int -> action) -> Sub action
forall action. (Set Int -> action) -> Sub action
keyboardSub ((Set Int -> action) -> Sub action)
-> ((Arrows -> action) -> Set Int -> action)
-> (Arrows -> action)
-> Sub action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Arrows -> action) -> (Set Int -> Arrows) -> Set Int -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows
toArrows ([Int], [Int], [Int], [Int])
dirs)
keyboardSub :: (Set Int -> action) -> Sub action
keyboardSub :: (Set Int -> action) -> Sub action
keyboardSub Set Int -> action
f Sink action
sink = do
IORef (Set Int)
keySetRef <- IO (IORef (Set Int)) -> JSM (IORef (Set Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Set Int -> IO (IORef (Set Int))
forall a. a -> IO (IORef a)
newIORef Set Int
forall a. Monoid a => a
mempty)
MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
"keyup" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Set Int) -> JSVal -> JSM ()
keyUpCallback IORef (Set Int)
keySetRef
MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
"keydown" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Set Int) -> JSVal -> JSM ()
keyDownCallback IORef (Set Int)
keySetRef
MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
"blur" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Set Int) -> JSVal -> JSM ()
forall (m :: * -> *) a p. MonadIO m => IORef (Set a) -> p -> m ()
blurCallback IORef (Set Int)
keySetRef
where
keyDownCallback :: IORef (Set Int) -> JSVal -> JSM ()
keyDownCallback IORef (Set Int)
keySetRef = \JSVal
keyDownEvent -> do
Just Int
key <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
getProp JSString
"keyCode" (JSVal -> Object
Object JSVal
keyDownEvent)
Set Int
newKeys <- IO (Set Int) -> JSM (Set Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set Int) -> JSM (Set Int)) -> IO (Set Int) -> JSM (Set Int)
forall a b. (a -> b) -> a -> b
$ IORef (Set Int) -> (Set Int -> (Set Int, Set Int)) -> IO (Set Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Set Int)
keySetRef ((Set Int -> (Set Int, Set Int)) -> IO (Set Int))
-> (Set Int -> (Set Int, Set Int)) -> IO (Set Int)
forall a b. (a -> b) -> a -> b
$ \Set Int
keys ->
let !new :: Set Int
new = Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
key Set Int
keys
in (Set Int
new, Set Int
new)
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (Set Int -> action
f Set Int
newKeys))
keyUpCallback :: IORef (Set Int) -> JSVal -> JSM ()
keyUpCallback IORef (Set Int)
keySetRef = \JSVal
keyUpEvent -> do
Just Int
key <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
getProp JSString
"keyCode" (JSVal -> Object
Object JSVal
keyUpEvent)
Set Int
newKeys <- IO (Set Int) -> JSM (Set Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set Int) -> JSM (Set Int)) -> IO (Set Int) -> JSM (Set Int)
forall a b. (a -> b) -> a -> b
$ IORef (Set Int) -> (Set Int -> (Set Int, Set Int)) -> IO (Set Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Set Int)
keySetRef ((Set Int -> (Set Int, Set Int)) -> IO (Set Int))
-> (Set Int -> (Set Int, Set Int)) -> IO (Set Int)
forall a b. (a -> b) -> a -> b
$ \Set Int
keys ->
let !new :: Set Int
new = Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.delete Int
key Set Int
keys
in (Set Int
new, Set Int
new)
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (Set Int -> action
f Set Int
newKeys))
blurCallback :: IORef (Set a) -> p -> m ()
blurCallback IORef (Set a)
keySetRef = \p
_ -> do
Set Int
newKeys <- IO (Set Int) -> m (Set Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set Int) -> m (Set Int)) -> IO (Set Int) -> m (Set Int)
forall a b. (a -> b) -> a -> b
$ IORef (Set a) -> (Set a -> (Set a, Set Int)) -> IO (Set Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Set a)
keySetRef ((Set a -> (Set a, Set Int)) -> IO (Set Int))
-> (Set a -> (Set a, Set Int)) -> IO (Set Int)
forall a b. (a -> b) -> a -> b
$ \Set a
_ ->
let !new :: Set a
new = Set a
forall a. Set a
S.empty
in (Set a
forall a. Set a
new, Set Int
forall a. Set a
new)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (Set Int -> action
f Set Int
newKeys))