{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE OverloadedStrings   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Keyboard
-- Copyright   :  (C) 2016-2018 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>
-- 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           GHCJS.Marshal
import           JavaScript.Object
import           JavaScript.Object.Internal

import           Miso.Effect (Sub)
import           Miso.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
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)

-- | Helper function to convert keys currently pressed to `Arrow`, 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 :: 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')

-- | Maps `Arrows` onto a Keyboard subscription
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])

-- | Maps `WASD` onto a Keyboard subscription for directions
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])

-- | Maps a specified list of keys to directions (up, down, left, right)
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)

-- | Returns subscription for Keyboard
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))

      -- 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 -> 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))