-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to
-- bind certain actions to other actions.
module Wetterhorn.Dsl.Bind
  ( bind,
    (.+),
    MatchEvent (..),
    Modifier (..),
    released,
    weak,
    run,
    modifierToMask,
    module X,
  )
where

import Control.Monad
import Control.Monad.Trans
import Data.Bits
import Data.Word
import Wetterhorn.Core.ButtonEvent (ButtonEvent(..))
import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
import Wetterhorn.Core.KeyEvent (KeyEvent(..))
import qualified Wetterhorn.Core.KeyEvent as KeyEvent
import Wetterhorn.Core.W
import Wetterhorn.Dsl.Buttons as X
import Wetterhorn.Dsl.Input

class MatchEvent m where
  matches :: m -> InputEvent -> W Bool

instance MatchEvent (InputEvent -> W Bool) where
  matches = ($)

instance MatchEvent Char where
  matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch
  matches _ _ = return False

instance MatchEvent Button where
  matches (Button b) (InputButtonEvent be) =
    return $ ButtonEvent.button be == b
  matches _ _ = return False

-- | Enumeration of possible modifiers.
--
-- ModX can be used for extra user-defined modifiers which are not standard xkb
-- modifiers.
data Modifier
  = Shift
  | Lock
  | Control
  | Mod1
  | Mod2
  | Mod3
  | Mod4
  | Mod5
  | ModX Int
  deriving (Eq, Ord, Show, Read)

-- | Converts a modifier to its associated mask.
modifierToMask :: Modifier -> Word32
modifierToMask m =
  1
    `shiftL` case m of
      Shift -> 0
      Lock -> 1
      Control -> 2
      Mod1 -> 3
      Mod2 -> 4
      Mod3 -> 5
      Mod4 -> 6
      Mod5 -> 7
      ModX b -> b + 8

released :: (MatchEvent m) => m -> InputEvent -> W Bool
released me ev | not (isPressEvent ev) = matches me ev
released _ _ = return False

data MatchModifiers = MatchModifiers
  { weakModifierMatch :: Bool,
    modifierMask :: Word32,
    baseMatch :: InputEvent -> W Bool
  }

instance MatchEvent MatchModifiers where
  matches (MatchModifiers weak bits base) ev = do
    mods <- getMods ev
    b <- liftW $ base ev

    return $
      b
        && ( (not weak && mods == bits)
               || (weak && (bits .&. mods == bits))
           )
    where
      getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods
      getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods
      getMods _ = getModifierState

class LiftMatchModifiers a where
  toModifiers :: a -> MatchModifiers
  default toModifiers :: (MatchEvent a) => a -> MatchModifiers
  toModifiers = MatchModifiers False 0 . matches

instance LiftMatchModifiers MatchModifiers where
  toModifiers = id

instance LiftMatchModifiers Char

instance LiftMatchModifiers Button

-- toModifiers ch = MatchModifiers False 0 (matches ch)

(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers
(.+) modifier (toModifiers -> (MatchModifiers b mask base)) =
  MatchModifiers b (mask .|. modifierToMask modifier) base

infixr 9 .+

bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy ()
bind ev match action = do
  matches' <- liftW $ matches match ev
  when matches' (action >> continue)

weak :: MatchModifiers -> MatchModifiers
weak m = m {weakModifierMatch = True}

run :: W () -> InputM spy ()
run = liftW