-----------------------------------------------------------------------------
{-# 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.Set
import qualified Data.Set as S
import           Language.Javascript.JSaddle hiding (new)
-----------------------------------------------------------------------------
import           Miso.Effect (Sub)
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]) -> Set Int -> Arrows
toArrows :: ([Int], [Int], [Int], [Int]) -> Set Int -> Arrows
toArrows ([Int]
up, [Int]
down, [Int]
left, [Int]
right) Set Int
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 -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Int
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 = (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)
-----------------------------------------------------------------------------
-- | Returns subscription for Keyboard.
-- The callback will be called with the Set of currently pressed @keyCode@s.
keyboardSub :: (Set Int -> action) -> Sub action
keyboardSub :: forall action. (Set Int -> action) -> Sub action
keyboardSub Set Int -> action
f Sink action
sink = do
  keySetRef <- IO (IORef (Set Int)) -> JSM (IORef (Set Int))
forall a. IO a -> JSM a
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)
  FFI.windowAddEventListener "keyup" $ keyUpCallback keySetRef
  FFI.windowAddEventListener "keydown" $ keyDownCallback keySetRef
  FFI.windowAddEventListener "blur" $ blurCallback keySetRef
    where
      keyDownCallback :: IORef (Set Int) -> JSVal -> JSM ()
keyDownCallback IORef (Set Int)
keySetRef = \JSVal
keyDownEvent -> do
          Just 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)
          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \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)
          sink (f newKeys)

      keyUpCallback :: IORef (Set Int) -> JSVal -> JSM ()
keyUpCallback IORef (Set Int)
keySetRef = \JSVal
keyUpEvent -> do
          Just 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)
          newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \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)
          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 (Set a) -> p -> JSM ()
blurCallback IORef (Set a)
keySetRef = \p
_ -> do
          newKeys <- IO (Set Int) -> JSM (Set Int)
forall a. IO a -> JSM a
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 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)
          sink (f newKeys)
-----------------------------------------------------------------------------