-----------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Keyboard
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.Keyboard
  ( -- *** Types
    Arrows (..)
    -- *** Subscriptions
  , 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
-----------------------------------------------------------------------------
-- | type for arrow keys currently pressed
--
--  * 37 left arrow  ( x = -1 )
--  * 38 up arrow    ( y =  1 )
--  * 39 right arrow ( x =  1 )
--  * 40 down arrow  ( y = -1 )
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)
-----------------------------------------------------------------------------
-- | Helper function to convert keys currently pressed to @Arrows@, given a
-- mapping for keys representing up, down, left and right respectively.
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')
-----------------------------------------------------------------------------
-- | Maps @Arrows@ onto a Keyboard subscription
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])
-----------------------------------------------------------------------------
-- | Maps @Arrows@ onto a Keyboard subscription for directions (W+A+S+D keys)
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])
-----------------------------------------------------------------------------
-- | Maps a specified list of keys to directions (up, down, left, right)
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)
-----------------------------------------------------------------------------
-- | Returns @Subscription@ for keyboard.
-- The callback will be called with the Set of currently pressed @keyCode@s.
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)
    
          -- Assume keys are released the moment focus is lost. Otherwise going
          -- back and forth to the app can cause keys to get stuck.
          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)
-----------------------------------------------------------------------------