src/Wetterhorn/Keys/MagicModifierKey.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

module Wetterhorn.Keys.MagicModifierKey where

import Data.Data
import Data.Default.Class
import GHC.TypeNats
import Wetterhorn.Core.KeyEvent
import Wetterhorn.Core.W
import Wetterhorn.Dsl.Bind
import Wetterhorn.Dsl.Input
import Control.Monad.RWS (MonadTrans(lift))
import Control.Monad.Trans.Maybe (MaybeT(..))

data MagicModifierProxy (keycode :: Natural) inputproxy
  deriving (Typeable)

newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool}
  deriving (Typeable, Eq, Show, Ord, Read)

instance Default (MagicModifierState k) where
  def = MagicModifierState False

instance (KnownNat k) => ExtensionClass (MagicModifierState k)

instance
  (KnownNat keycode, InputProxy inputproxy) =>
  InputProxy (MagicModifierProxy keycode inputproxy)
  where
  onKeyEvent proxy ie = do
    case ie of
      (InputKeyEvent (KeyEvent {keycode = kc, state = state}))
        | fromIntegral kc == natVal (keycodeProxy proxy) -> do
          lift $ setMagicModifierPressed proxy (state == KeyPressed)
          MaybeT (return Nothing)
      _ -> do
        pressed <- lift $ isMagicModifierPressed proxy
        if pressed
          then onKeyEvent (Proxy :: Proxy inputproxy) ie
          else return ie
    where
      keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc
      keycodeProxy _ = Proxy

      isMagicModifierPressed p = isPressed <$> getModState p
      setMagicModifierPressed p = modifyModState p . const

      getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc)
      getModState _ = xget

      modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W ()
      modifyModState _ fn = xmodify (MagicModifierState . fn)