Keys.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module YMonad.Keys (
  KeyMask (..),
  KeySym (..),
  noModMask,
  shiftMask,
  controlMask,
  mod1Mask,
  mod3Mask,
  mod4Mask,
  mod5Mask,
  xK_Return,
  xK_return,
  xK_Tab,
  xK_ISO_Left_Tab,
  xK_space,
  xK_j,
  xK_k,
  xK_h,
  xK_l,
  xK_c,
  xK_p,
  xK_s,
  xK_q,
  xK_F1,
  xK_comma,
  xK_period,
  xK_1,
  xK_2,
  xK_3,
  xK_4,
  xK_5,
  xK_6,
  xK_7,
  xK_8,
  xK_9,
  renderKeyMask,
  renderKeySym,
  keySymToXkb,
) where

import Data.Bits (Bits, FiniteBits, (.&.))
import Data.Text qualified as T

newtype KeyMask = KeyMask
  { unKeyMask :: Word32
  }
  deriving stock (Eq, Ord, Show)
  deriving newtype (Bits, FiniteBits, Num)

newtype KeySym = KeySym
  { unKeySym :: Text
  }
  deriving stock (Eq, Ord, Show)

noModMask, shiftMask, controlMask, mod1Mask, mod3Mask, mod4Mask, mod5Mask :: KeyMask
noModMask = KeyMask 0
shiftMask = KeyMask 1
controlMask = KeyMask 4
mod1Mask = KeyMask 8
mod3Mask = KeyMask 32
mod4Mask = KeyMask 64
mod5Mask = KeyMask 128

xK_Return, xK_return, xK_Tab, xK_ISO_Left_Tab, xK_space, xK_j, xK_k, xK_h, xK_l, xK_c, xK_p, xK_s, xK_q, xK_comma, xK_period, xK_F1 :: KeySym
xK_Return = KeySym "Return"
xK_return = xK_Return
xK_Tab = KeySym "Tab"
xK_ISO_Left_Tab = KeySym "ISO_Left_Tab"
xK_space = KeySym "space"
xK_j = KeySym "j"
xK_k = KeySym "k"
xK_h = KeySym "h"
xK_l = KeySym "l"
xK_c = KeySym "c"
xK_p = KeySym "p"
xK_s = KeySym "s"
xK_q = KeySym "q"
xK_F1 = KeySym "F1"
xK_comma = KeySym "comma"
xK_period = KeySym "period"

xK_1, xK_2, xK_3, xK_4, xK_5, xK_6, xK_7, xK_8, xK_9 :: KeySym
xK_1 = KeySym "1"
xK_2 = KeySym "2"
xK_3 = KeySym "3"
xK_4 = KeySym "4"
xK_5 = KeySym "5"
xK_6 = KeySym "6"
xK_7 = KeySym "7"
xK_8 = KeySym "8"
xK_9 = KeySym "9"

renderKeyMask :: KeyMask -> Text
renderKeyMask mask
  | unKeyMask mask == 0 = "None"
  | otherwise = T.intercalate "+" (map snd (filter fst parts))
  where
    includes wanted = (unKeyMask mask .&. unKeyMask wanted) /= 0
    parts =
      [ (includes shiftMask, "Shift")
      , (includes controlMask, "Control")
      , (includes mod1Mask, "Mod1")
      , (includes mod3Mask, "Mod3")
      , (includes mod4Mask, "Mod4")
      , (includes mod5Mask, "Mod5")
      ]

renderKeySym :: KeySym -> Text
renderKeySym = unKeySym

keySymToXkb :: KeySym -> Maybe Word32
keySymToXkb (KeySym sym) =
  case sym of
    "Return" -> Just 0xFF0D
    "Escape" -> Just 0xFF1B
    "Tab" -> Just 0xFF09
    "ISO_Left_Tab" -> Just 0xFE20
    "space" -> Just 0x0020
    "comma" -> Just 0x002C
    "period" -> Just 0x002E
    "F1" -> Just 0xFFBE
    _ ->
      case toString sym of
        [ch] -> Just (fromIntegral (ord ch))
        _ -> Nothing