Have macro support (again) and some type-level goodness.

4 files changed, 145 insertions, 87 deletions

diff --git a/src/Config.hs b/src/Config.hs
index ca99aad..0bd0d43 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,9 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+
 module Config (config) where
 
-import Control.Monad (unless, when)
-import Control.Monad.IO.Class
-import Control.Monad.Loops
-import Text.Printf
+import Control.Monad (unless)
+import Data.Data (Proxy (Proxy))
 import Wetterhorn.Core.W
 import Wetterhorn.Dsl.Bind
 import Wetterhorn.Dsl.Input
@@ -20,33 +20,39 @@ config =
           },
       layout = WindowLayout Full,
       resetHook = do
-        useInputHandler $ do
-          ev <- nextInputEvent
+        useInputHandler $
+          withProxies inputProxies $ do
+            ev <- nextInputEvent
 
-          macroSupport
-            (Mod1 .+ 'q')
-            (weak $ Mod1 .+ '@')
-            ev
+            bind ev (released btnLeft) $
+              run $
+                wio $ putStrLn "Left Button Released!!"
 
-          bind ev (released btnLeft) $ do
-            wio $ putStrLn "Left Button Released!!"
+            unless (isPressEvent ev) $ do
+              forwardEvent ev
+              continue
 
-          unless (isPressEvent ev) $ do
-            forwardEvent ev
-            continue
+            bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload
 
-          bind ev (Shift .+ Mod1 .+ 'R') requestHotReload
+            bind ev (Mod1 .+ 't') $ run (shellExec "alacritty")
 
-          bind ev (Mod1 .+ 't') (shellExec "alacritty")
+            bind ev (Mod1 .+ 'p') $ do
+              ev2 <- nextInputPressEvent
 
-          bind ev (Mod1 .+ 'p') $ do
-            ev2 <- nextInputPressEvent
+              bind ev2 (Mod1 .+ 'p') $
+                run $
+                  wio $ putStrLn "Test"
 
-            bind ev2 (Mod1 .+ 'p') $ do
-              wio $ putStrLn "Test"
+            bind ev (Mod1 .+ btnLeft) $
+              run $
+                wio $ putStrLn "Left Button Press!!"
 
-          bind ev (Mod1 .+ btnLeft) $ do
-            wio $ putStrLn "Left Button Press!!"
+            bind ev (Mod1 .+ 'q') macroStartStopKeybind
 
-          forwardEvent ev
+            bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
+
+            forwardEvent ev
     }
+  where
+    inputProxies :: Proxy '[MacroSupport, KeyLogger]
+    inputProxies = Proxy
diff --git a/src/Wetterhorn/Dsl/Bind.hs b/src/Wetterhorn/Dsl/Bind.hs
index 7bdb9de..f6cdd7e 100644
--- a/src/Wetterhorn/Dsl/Bind.hs
+++ b/src/Wetterhorn/Dsl/Bind.hs
@@ -7,7 +7,7 @@ module Wetterhorn.Dsl.Bind
     Modifier (..),
     released,
     weak,
-    spy,
+    run,
     module X,
   )
 where
@@ -23,9 +23,9 @@ import Wetterhorn.Dsl.Buttons as X
 import Wetterhorn.Dsl.Input
 
 class MatchEvent m where
-  matches :: m -> InputEvent -> InputM Bool
+  matches :: m -> InputEvent -> W Bool
 
-instance MatchEvent (InputEvent -> InputM Bool) where
+instance MatchEvent (InputEvent -> W Bool) where
   matches = ($)
 
 instance MatchEvent Char where
@@ -37,15 +37,6 @@ instance MatchEvent Button where
     return $ ButtonEvent.button be == b
   matches _ _ = return False
 
-class InputAction m where
-  doAction :: m -> InputM ()
-
-instance (a ~ ()) => InputAction (W a) where
-  doAction = liftW
-
-instance (a ~ ()) => InputAction (InputM a) where
-  doAction = id
-
 -- | Enumeration of possible modifiers
 data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
   deriving (Eq, Ord, Show, Read, Enum, Bounded)
@@ -64,19 +55,19 @@ modifierToMask m =
       Mod4 -> 6
       Mod5 -> 7
 
-released :: (MatchEvent m) => m -> InputEvent -> InputM Bool
+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 -> InputM Bool
+    baseMatch :: InputEvent -> W Bool
   }
 
 instance MatchEvent MatchModifiers where
   matches (MatchModifiers weak bits base) ev@(InputKeyEvent ke) = do
-    b <- base ev
+    b <- liftW $ base ev
 
     return $
       b
@@ -85,7 +76,7 @@ instance MatchEvent MatchModifiers where
            )
   matches (MatchModifiers weak bits base) ev = do
     mods <- liftW getModifierState
-    b <- base ev
+    b <- liftW $ base ev
 
     return $
       b
@@ -113,17 +104,13 @@ instance LiftMatchModifiers Button
 
 infixr 9 .+
 
--- | Like 'bind', but does not restart consume the event and start from the top,
--- rather it continues the operation as normal.
-spy :: (MatchEvent match, InputAction action) => InputEvent -> match -> action -> InputM ()
-spy ev match action = do
-  matches' <- matches match ev
-  when matches' (doAction action)
-
-bind :: (MatchEvent match, InputAction action) => InputEvent -> match -> action -> InputM ()
+bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy ()
 bind ev match action = do
-  matches' <- matches match ev
-  when matches' (doAction action >> continue)
+  matches' <- liftW $ matches match ev
+  when matches' (action >> continue)
 
 weak :: MatchModifiers -> MatchModifiers
 weak m = m {weakModifierMatch = True}
+
+run :: W () -> InputM spy ()
+run = liftW
diff --git a/src/Wetterhorn/Dsl/Input.hs b/src/Wetterhorn/Dsl/Input.hs
index 625a64b..1d1a89a 100644
--- a/src/Wetterhorn/Dsl/Input.hs
+++ b/src/Wetterhorn/Dsl/Input.hs
@@ -1,6 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+
 module Wetterhorn.Dsl.Input
   ( InputM,
     InputEvent (..),
+    InputProxy (..),
+    withProxies,
     forwardEvent,
     forwardKey,
     whenKeyEvent,
@@ -20,10 +24,11 @@ module Wetterhorn.Dsl.Input
 where
 
 import Control.Concurrent (forkIO, threadDelay)
-import Control.Monad (forever, join, void, (>=>))
+import Control.Monad
 import Control.Monad.Cont (MonadCont)
-import Control.Monad.RWS (MonadIO (liftIO), MonadReader (ask, local), MonadState (get), MonadTrans (lift), RWST, asks, execRWST, gets, modify)
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader (ask, local), MonadState (get), MonadTrans (lift), RWST, asks, execRWST, gets, mapRWST, modify)
 import Control.Monad.Trans.Cont
+import Data.Proxy
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.Maybe (fromMaybe)
 import Data.Word (Word32)
@@ -33,34 +38,51 @@ import Wetterhorn.Core.W (W (..))
 import qualified Wetterhorn.Core.W as W
 import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
 
+class InputProxy (spy :: k) where
+  onKeyEvent :: Proxy spy -> InputEvent -> W InputEvent
+
+instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where
+  onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t)
+
+instance InputProxy '[] where
+  onKeyEvent _ = return
+
+data NoSpy
+
+instance InputProxy NoSpy where
+  onKeyEvent _ = return
+
+instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where
+  onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy)
+
 -- | Union of event types.
 data InputEvent
   = InputButtonEvent ButtonEvent.ButtonEvent
   | InputKeyEvent KeyEvent.KeyEvent
 
 -- | Context for the input.
-data InputContext = InputContext
+newtype InputContext spy = InputContext
   { -- | Top of the input routine. Used in "continue" statement.
-    inputTop :: InputM ()
+    inputTop :: InputM spy ()
   }
 
-newtype InputState = InputState
-  { inputSource :: InputM InputEvent
+newtype InputState spy = InputState
+  { inputSource :: InputM spy InputEvent
   }
 
 -- | Input monad for handling all kinds of input.
-newtype InputM a = InputM (ContT () (RWST InputContext () InputState W) a)
+newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a)
   deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
 
-instance MonadFail InputM where
+instance MonadFail (InputM spy) where
   fail _ = continue
 
 -- | Lifts a W action to an InputM action.
-instance W.Wlike InputM where
+instance W.Wlike (InputM spy) where
   liftW = InputM . lift . lift
 
 -- | Resets the input handler to the top.
-continue :: InputM a
+continue :: InputM spy a
 continue = do
   (InputContext {inputTop = (InputM top)}) <- InputM ask
   InputM $ shiftT (\_ -> resetT top)
@@ -104,12 +126,12 @@ forwardEvent = \case
 
 -- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the
 -- maybe is not present, the handler restarts execution from the top.
-unwrap :: Maybe a -> InputM a
+unwrap :: Maybe a -> InputM spy a
 unwrap (Just val) = return val
 unwrap Nothing = continue
 
 -- | Runs the series of events from the top as if they were input.
-replayEvents :: [InputEvent] -> InputM ()
+replayEvents :: [InputEvent] -> InputM spy ()
 replayEvents events = do
   ioref <- liftIO (newIORef events)
 
@@ -118,9 +140,9 @@ replayEvents events = do
   let newInput = InputM $ do
         r <- liftIO (readIORef ioref)
         case r of
-          [] -> do 
-             modify $ \st -> st {inputSource = oldInput}
-             let (InputM action) = oldInput in action
+          [] -> do
+            modify $ \st -> st {inputSource = oldInput}
+            let (InputM action) = oldInput in action
           (a : as) -> do
             liftIO (writeIORef ioref as)
             return a
@@ -128,15 +150,15 @@ replayEvents events = do
   InputM $ modify $ \st -> st {inputSource = newInput}
 
 -- | Call in the reset handler with the InputM handler you wolud like to use.
-useInputHandler :: InputM () -> W ()
+useInputHandler :: (InputProxy spy) => InputM spy () -> W ()
 useInputHandler (forever -> top@(InputM ctop)) = do
   void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents)
 
 -- | Returns the next input event that's either a kep press or a button press.
-nextInputPressEvent :: InputM InputEvent
+nextInputPressEvent :: InputM spy InputEvent
 nextInputPressEvent = nextInputEventThat isPressEvent
 
-nextInputEventThat :: (InputEvent -> Bool) -> InputM InputEvent
+nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent
 nextInputEventThat fn =
   nextInputEvent
     >>= ( \ie ->
@@ -160,7 +182,7 @@ isPressEvent _ = False
 
 -- | Returns the event only if it matches the filter. If it does not match the
 -- filter, execution resets to the top.
-filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM InputEvent
+filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent
 filterEvent fn ev | fn ev = return ev
 filterEvent _ _ = continue
 
@@ -170,11 +192,14 @@ getModifierState = do
   keyboard <- W.wio $ wlrSeatGetKeyboard seat
   maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)
 
-nextInputEvent :: InputM InputEvent
+nextInputEvent :: InputM spy InputEvent
 nextInputEvent = join $ InputM $ gets inputSource
 
+withProxies :: Proxy spy -> InputM spy a -> InputM spy a
+withProxies _ = id
+
 -- | Gets the next input event.
-useSeatEvents :: InputM InputEvent
+useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent
 useSeatEvents =
   InputM $
     shiftT
@@ -182,14 +207,18 @@ useSeatEvents =
           putButtonHandler $ \be -> do
             clearButtonHandler
             clearKeyHandler
-            thingToDo (InputButtonEvent be)
+            runSpies thingToDo (InputButtonEvent be)
 
           putKeyHandler $ \ke -> do
             clearButtonHandler
             clearKeyHandler
-            thingToDo (InputKeyEvent ke)
+            runSpies thingToDo (InputKeyEvent ke)
       )
   where
+    runSpies fn ev = do
+      ev' <- lift $ onKeyEvent (Proxy :: Proxy spy) ev
+      fn ev'
+
     clearButtonHandler =
       lift $
         modify $ \st ->
diff --git a/src/Wetterhorn/Keys/Macros.hs b/src/Wetterhorn/Keys/Macros.hs
index 73481b6..b7683df 100644
--- a/src/Wetterhorn/Keys/Macros.hs
+++ b/src/Wetterhorn/Keys/Macros.hs
@@ -1,17 +1,20 @@
+{-# LANGUAGE DataKinds #-}
+
 module Wetterhorn.Keys.Macros where
 
+import Control.Monad.IO.Class (MonadIO (liftIO))
 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 Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.W
 import Wetterhorn.Dsl.Input
-import Wetterhorn.Dsl.Bind
 import Wetterhorn.Foreign.WlRoots (WlrInputDevice)
-import Control.Monad.IO.Class (MonadIO(liftIO))
-import Control.Monad (when)
 
 data RecordedKey = RecordedKey Word32 KeyState Word32 Word32 Char
   deriving (Read, Show)
@@ -27,18 +30,16 @@ instance Default MacrosState where
 
 instance ExtensionClass MacrosState
 
-macroSupport :: (MatchEvent record, MatchEvent replay) => record -> replay -> InputEvent -> InputM ()
-macroSupport rec rep ev = do
-  when (isPressEvent ev) (bind ev rec macroStartStopKeybind)
-  recordMacroKey ev
-  when (isPressEvent ev) (bind ev rep macroReplayKeybind)
+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 :: InputM ()
+macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy ()
 macroStartStopKeybind = do
   currentlyRecordingMacro
     >>= ( \case
@@ -56,7 +57,7 @@ macroStartStopKeybind = do
 -- Designed to be used like:
 --
 --   bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
-macroReplayKeybind :: InputM ()
+macroReplayKeybind :: (HasMacroSupport spy) => InputM spy ()
 macroReplayKeybind = do
   ( InputKeyEvent
       (KeyEvent {codepoint = cp, device = device})
@@ -80,10 +81,11 @@ stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing})
 currentlyRecordingMacro :: (Wlike m) => m (Maybe String)
 currentlyRecordingMacro = xgets currentlyRecording
 
-replayMacro :: Ptr WlrInputDevice -> String -> InputM ()
+replayMacro :: Ptr WlrInputDevice -> String -> InputM spy ()
 replayMacro inputDevice s = do
   m <- liftW (Map.lookup s <$> xgets macros)
-  mapM_ (replayEvents . map toInputEvent . reverse) m
+  -- '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 kc st mo sym cp) =
@@ -103,5 +105,39 @@ pushMacroKey ke = do
 
     toRecordedKey (KeyEvent _ c s m sym cp _) = RecordedKey c s m sym cp
 
-recordMacroKey :: InputEvent -> InputM ()
-recordMacroKey ev = whenKeyEvent ev pushMacroKey
+data MacroSupport
+
+data KeyLogger
+
+instance InputProxy KeyLogger where
+  onKeyEvent _ ie = do
+    case ie of
+      (InputKeyEvent (KeyEvent {codepoint = c})) ->
+        wio $ print c
+      _ -> return ()
+    return ie
+
+instance InputProxy MacroSupport where
+  onKeyEvent _ ie = do
+    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