[refactor] Wetterhorn -> Montis

2 files changed, 195 insertions, 0 deletions

diff --git a/plug/src/Montis/Keys/Macros.hs b/plug/src/Montis/Keys/Macros.hs
new file mode 100644
index 0000000..37f4db4
--- /dev/null
+++ b/plug/src/Montis/Keys/Macros.hs
@@ -0,0 +1,145 @@
+-- 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
diff --git a/plug/src/Montis/Keys/MagicModifierKey.hs b/plug/src/Montis/Keys/MagicModifierKey.hs
new file mode 100644
index 0000000..0cf1eb3
--- /dev/null
+++ b/plug/src/Montis/Keys/MagicModifierKey.hs
@@ -0,0 +1,50 @@
+module Montis.Keys.MagicModifierKey where
+
+import Data.Data
+import Data.Default.Class
+import GHC.TypeNats
+import Montis.Core.KeyEvent
+import Montis.Core.W
+import Montis.Dsl.Bind
+import Montis.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)