-- There are constraints used for better type-level enforced safety rules.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Montis.Keys.Macros
  ( MacroSupport,
    macroStartStopKeybind,
    macroReplayKeybind,
    stopMacroRecording,
    startRecording,
  )
where

import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans (MonadTrans (lift))
import Data.Default.Class
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Type.Bool
import Data.Type.Equality
import Data.Word
import Foreign (Ptr)
import GHC.TypeError
import Montis.Core.KeyEvent
import Montis.Core.W
import Montis.Dsl.Input
import Montis.Foreign.WlRoots (WlrInputDevice)

data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char
  deriving (Read, Show)

data MacrosState = MacrosState
  { macros :: Map String [RecordedKey],
    currentlyRecording :: Maybe String
  }
  deriving (Read, Show)

instance Default MacrosState where
  def = MacrosState mempty def

instance ExtensionClass MacrosState

type family Find a ls where
  Find b (a : t) = (b == a) || Find b t
  Find _ '[] = False

-- | Provides a Vim-esque keybinding behavior for macro recording.
--
-- Designed to be used like:
--
--   bind ev (Mod1 .+ 'q') macroStartStopKeybind
macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy ()
macroStartStopKeybind = do
  currentlyRecordingMacro
    >>= ( \case
            Just ch -> do
              liftIO $ putStrLn $ "Done Recording: " ++ ch
              stopMacroRecording
            Nothing -> do
              (InputKeyEvent (KeyEvent {codepoint = cp})) <- nextInputPressEvent
              liftIO $ putStrLn $ "Recording: " ++ [cp]
              startRecording [cp]
        )

-- | Provides a keybinding for replaying a macro.
--
-- Designed to be used like:
--
--   bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
macroReplayKeybind :: (HasMacroSupport spy) => InputM spy ()
macroReplayKeybind = do
  ( InputKeyEvent
      (KeyEvent {codepoint = cp, device = device})
    ) <-
    nextInputPressEvent
  replayMacro device [cp]

startRecording :: (Wlike m) => String -> m ()
startRecording ch =
  xmodify
    ( \m@MacrosState {macros = macros} ->
        m
          { macros = Map.delete ch macros,
            currentlyRecording = Just ch
          }
    )

stopMacroRecording :: (Wlike m) => m ()
stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing})

currentlyRecordingMacro :: (Wlike m) => m (Maybe String)
currentlyRecordingMacro = xgets currentlyRecording

replayMacro :: Ptr WlrInputDevice -> String -> InputM spy ()
replayMacro inputDevice s = do
  m <- liftW (Map.lookup s <$> xgets macros)
  -- 'tail' is to cut off the last keystroke which stops the recording.
  mapM_ (replayEvents . map toInputEvent . reverse . tail) m
  where
    toInputEvent :: RecordedKey -> InputEvent
    toInputEvent (RecordedKey ts kc st mo keysym cp) =
      InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice

pushMacroKey :: (Wlike m) => KeyEvent -> m ()
pushMacroKey ke = do
  cur <- xgets currentlyRecording
  whenJust cur $ \ch -> do
    let recordedKey = toRecordedKey ke
     in xmodify $ \m@MacrosState {macros = macros} ->
          m {macros = Map.insertWith (++) ch [recordedKey] macros}
  where
    whenJust (Just a) fn = fn a
    whenJust _ _ = return ()

    toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp

-- | Phantom type defining a proxy required to support macros.
data MacroSupport

-- | Instance for macro support.
instance InputProxy MacroSupport where
  onKeyEvent _ ie = do
    lift $ whenKeyEvent ie pushMacroKey
    return ie

class HasMacroSupport t

instance
  ( If
      (Find MacroSupport t)
      True
      ( TypeError
          ( Text "This Requires the Macro Proxy to be Enabled."
              :<>: Text "Please enable this by adding MacroSupport to your"
              :<>: Text "inputProxies list.\n"
              :<>: Text "i.e. Change "
              :<>: ShowType t
              :<>: Text " to "
              :<>: ShowType (MacroSupport ': t)
          )
      )
      ~ True
  ) =>
  HasMacroSupport t

instance HasMacroSupport MacroSupport