{-# LANGUAGE ImpredicativeTypes #-}

-- | Small DSL for defining key bindings and nested sub-maps.
module Montis.Standard.Bindings.Dsl where

import Control.Monad.Loops (anyM)
import Data.Bits (shiftL, (.&.))
import Data.Word (Word32)
import Montis.Core (ButtonEvent (buttonEvent_button, buttonEvent_modifiers, buttonEvent_state), ButtonState (ButtonPressed), Config, KeyEvent (keyEvent_codepoint, keyEvent_modifiers), Montis (..), install)
import Montis.Standard.Bindings
import Montis.Standard.Bindings.Button

-- | A predicate over a key event.
class InputMatch a where
  matches :: a -> InputEvent -> Montis Bool

instance InputMatch Char where
  matches c (InputEvent (Left k)) = return $ keyEvent_codepoint k == c
  matches _ _ = return False

-- | Modifier matches using wlroots bit positions.
data Modifier = Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Any | None

instance InputMatch Modifier where
  matches Mod1 ev = return $ inputModifiers ev .&. (1 `shiftL` 3) /= 0
  matches Mod2 ev = return $ inputModifiers ev .&. (1 `shiftL` 4) /= 0
  matches Mod3 ev = return $ inputModifiers ev .&. (1 `shiftL` 5) /= 0
  matches Mod4 ev = return $ inputModifiers ev .&. (1 `shiftL` 6) /= 0
  matches Mod5 ev = return $ inputModifiers ev .&. (1 `shiftL` 7) /= 0
  matches Any _ = return True
  matches None ev = return $ inputModifiers ev == 0

instance InputMatch Button where
  matches (Button b) (InputEvent (Right ev)) =
    return $ buttonEvent_button ev == b && buttonEvent_state ev == ButtonPressed
  matches _ _ = return False

inputModifiers :: InputEvent -> Word32
inputModifiers (InputEvent (Left k)) = keyEvent_modifiers k
inputModifiers (InputEvent (Right b)) = buttonEvent_modifiers b

-- | Actions run when a binding matches. Each action reports handled status.
class Action b where
  run :: b -> Montis Bool

instance Action (Montis ()) where
  run a = a >> return True

instance Action (InputEvent -> Montis ()) where
  run f = subkeys (\e -> f e >> return True)

instance Action (KeyEvent -> Montis ()) where
  run f =
    subkeys
      ( \case
          (InputEvent (Left k)) -> f k >> return True
          _ -> return True
      )

instance Action (ButtonEvent -> Montis ()) where
  run f =
    subkeys
      ( \case
          (InputEvent (Right b)) -> f b >> return True
          _ -> return True
      )

-- | Submap to the first binding that matches.
instance Action [Binding] where
  run bs = subkeys $ \ev ->
    anyM
      ( \(Bind k a) -> do
          m <- matches k ev
          if m then run a >> return True else return False
      )
      bs

instance Action (Montis [Binding]) where
  run mbs = do
    bs <- mbs
    run bs

-- | A single binding from a matcher to an action.
data Binding where
  Bind :: forall k b. (InputMatch k, Action b) => k -> b -> Binding

-- | A matcher for key + modifier chords.
data ChordMatch where
  ChordMatch :: forall k2 k1. (InputMatch k2, InputMatch k1) => k2 -> k1 -> ChordMatch

(.+) :: (InputMatch k1, InputMatch k2) => k1 -> k2 -> ChordMatch
(.+) = ChordMatch

instance InputMatch ChordMatch where
  matches (ChordMatch a b) ev = do
    ma <- matches a ev
    mb <- matches b ev
    return (ma && mb)

-- | Installs the bindings into a config as the starting key hook.
withBindings :: [Binding] -> Config Montis -> Config Montis
withBindings bs =
  install
    ( InputsConfig
        ( \ev ->
            anyM
              ( \(Bind k a) -> do
                  m <- matches k ev
                  if m then run a >> return True else return False
              )
              bs
        )
    )