{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Miso.Subscription.Keyboard
(
Arrows (..)
, arrowsSub
, directionSub
, keyboardSub
, wasdSub
) where
import Control.Monad.IO.Class
import Data.IORef
import Data.IntSet
import qualified Data.IntSet as S
import Language.Javascript.JSaddle hiding (new)
import Miso.Effect (Sub)
import Miso.Subscription.Util (createSub)
import qualified Miso.FFI.Internal as 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
$cshowsPrec :: Int -> Arrows -> ShowS
showsPrec :: Int -> Arrows -> ShowS
$cshow :: Arrows -> String
show :: Arrows -> String
$cshowList :: [Arrows] -> ShowS
showList :: [Arrows] -> ShowS
Show, Arrows -> Arrows -> Bool
(Arrows -> Arrows -> Bool)
-> (Arrows -> Arrows -> Bool) -> Eq Arrows
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Arrows -> Arrows -> Bool
== :: Arrows -> Arrows -> Bool
$c/= :: Arrows -> Arrows -> Bool
/= :: Arrows -> Arrows -> Bool
Eq)
toArrows :: ([Int], [Int], [Int], [Int]) -> IntSet -> Arrows
toArrows :: ([Int], [Int], [Int], [Int]) -> IntSet -> Arrows
toArrows ([Int]
up, [Int]
down, [Int]
left, [Int]
right) IntSet
set' = 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 -> IntSet -> Bool
`S.member` IntSet
set')
arrowsSub :: (Arrows -> action) -> Sub action
arrowsSub :: forall action. (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 :: forall action. (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 :: forall action.
([Int], [Int], [Int], [Int]) -> (Arrows -> action) -> Sub action
directionSub ([Int], [Int], [Int], [Int])
dirs = (IntSet -> action) -> Sub action
forall action. (IntSet -> action) -> Sub action
keyboardSub ((IntSet -> action) -> Sub action)
-> ((Arrows -> action) -> IntSet -> action)
-> (Arrows -> action)
-> Sub action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Arrows -> action) -> (IntSet -> Arrows) -> IntSet -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int], [Int], [Int], [Int]) -> IntSet -> Arrows
toArrows ([Int], [Int], [Int], [Int])
dirs)
keyboardSub :: (IntSet -> action) -> Sub action
keyboardSub :: forall action. (IntSet -> action) -> Sub action
keyboardSub IntSet -> action
f Sink action
sink = JSM (Function, Function, Function)
-> ((Function, Function, Function) -> JSM ()) -> Sub action
forall a b action. JSM a -> (a -> JSM b) -> Sub action
createSub JSM (Function, Function, Function)
acquire (Function, Function, Function) -> JSM ()
release Sink action
sink
where
release :: (Function, Function, Function) -> JSM ()
release (Function
cb1, Function
cb2, Function
cb3) = do
MisoString -> Function -> JSM ()
FFI.windowRemoveEventListener MisoString
"keyup" Function
cb1
MisoString -> Function -> JSM ()
FFI.windowRemoveEventListener MisoString
"keydown" Function
cb2
MisoString -> Function -> JSM ()
FFI.windowRemoveEventListener MisoString
"blur" Function
cb3
acquire :: JSM (Function, Function, Function)
acquire = do
keySetRef <- IO (IORef IntSet) -> JSM (IORef IntSet)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IntSet -> IO (IORef IntSet)
forall a. a -> IO (IORef a)
newIORef IntSet
forall a. Monoid a => a
mempty)
cb1 <- FFI.windowAddEventListener "keyup" (keyUpCallback keySetRef)
cb2 <- FFI.windowAddEventListener "keydown" (keyDownCallback keySetRef)
cb3 <- FFI.windowAddEventListener "blur" (blurCallback keySetRef)
pure (cb1, cb2, cb3)
where
keyDownCallback :: IORef IntSet -> JSVal -> JSM ()
keyDownCallback IORef IntSet
keySetRef = \JSVal
keyDownEvent -> do
key <- JSVal -> JSM Int
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Int) -> JSM JSVal -> JSM Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> JSM JSVal
getProp MisoString
"keyCode" (JSVal -> Object
Object JSVal
keyDownEvent)
newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \IntSet
keys ->
let !new :: IntSet
new = Int -> IntSet -> IntSet
S.insert Int
key IntSet
keys
in (IntSet
new, IntSet
new)
sink (f newKeys)
keyUpCallback :: IORef IntSet -> JSVal -> JSM ()
keyUpCallback IORef IntSet
keySetRef = \JSVal
keyUpEvent -> do
key <- JSVal -> JSM Int
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked (JSVal -> JSM Int) -> JSM JSVal -> JSM Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MisoString -> Object -> JSM JSVal
getProp MisoString
"keyCode" (JSVal -> Object
Object JSVal
keyUpEvent)
newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \IntSet
keys ->
let !new :: IntSet
new = Int -> IntSet -> IntSet
S.delete Int
key IntSet
keys
in (IntSet
new, IntSet
new)
sink (f newKeys)
blurCallback :: IORef IntSet -> p -> JSM ()
blurCallback IORef IntSet
keySetRef = \p
_ -> do
newKeys <- IO IntSet -> JSM IntSet
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IntSet -> JSM IntSet) -> IO IntSet -> JSM IntSet
forall a b. (a -> b) -> a -> b
$ IORef IntSet -> (IntSet -> (IntSet, IntSet)) -> IO IntSet
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef IntSet
keySetRef ((IntSet -> (IntSet, IntSet)) -> IO IntSet)
-> (IntSet -> (IntSet, IntSet)) -> IO IntSet
forall a b. (a -> b) -> a -> b
$ \IntSet
_ ->
let !new :: IntSet
new = IntSet
S.empty
in (IntSet
new, IntSet
new)
sink (f newKeys)