Higher fidelity for extensible state.

3 files changed, 53 insertions, 50 deletions

diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index f7fb497..d82ac4c 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -88,8 +88,8 @@ nextKeyEvent = do
             handleContinuation st (\kp -> evalStateT (keyHandler kp) st)
       )
 
--- | Discards the rest of the continuation and stars again from the top. Useful
--- for keybinds where once the key is handled, just continue to the top.
+-- | Discards the rest of the continuation and starts again from the top. Useful
+-- for keybinds where once the key is handled, there's nothing left to do.
 continue :: KeysM ()
 continue = do
   st <- KeysM $ lift get
@@ -97,7 +97,7 @@ continue = do
 
   -- This shift discards the rest of the computation and instead returns to the
   -- top of the handler.
-  KeysM $ shiftT (\_ -> lift (evalContT topCont))
+  KeysM $ shiftT (\_ -> resetT topCont)
 
 -- | Returns the "top" continuation.
 getTop :: KeysM (KeysM ())
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index 79da19b..3b77ba8 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -8,7 +8,7 @@ import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify
 import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.State (StateT (runStateT), gets, modify')
 import Control.Monad.Trans.Maybe
-import Data.Data (Typeable, cast)
+import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage)
 import Data.Default.Class (Default, def)
 import Data.Kind (Constraint, Type)
 import Data.Map (Map)
@@ -18,8 +18,9 @@ import Data.Proxy
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
+import Text.Printf (printf)
 import Text.Read
-import Type.Reflection (someTypeRep)
+import Type.Reflection (someTypeRep, someTypeRepTyCon)
 import Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.SurfaceEvent
 import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
@@ -193,7 +194,51 @@ class (Typeable a) => ExtensionClass a where
 data StateExtension where
   StateExtension :: (ExtensionClass a) => a -> StateExtension
 
--- State as it is marshalled.
+-- | Puts a state extension.
+xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m ()
+xput val = liftW $ do
+  modify' $ \state@State {extensibleState = extensibleState} ->
+    state
+      { extensibleState =
+          M.insert
+            ( xRepr (Proxy :: Proxy a)
+            )
+            (Right $ StateExtension val)
+            extensibleState
+      }
+
+-- | Modifies a state extension.
+xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m ()
+xmodify fn = xput . fn =<< xget
+
+-- | Modifies a state extension in the monadic context.
+xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m ()
+xmodifyM fn = (xput <=< fn) =<< xget
+
+-- | Produces a string representation of a type used to key into the extensible
+-- state map.
+xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String
+xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a))
+  where
+    tyconToStr tc =
+      printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc)
+
+-- | Gets a state extension.
+xget :: forall a m. (ExtensionClass a, Wlike m) => m a
+xget = do
+  xs <- liftW $ gets extensibleState
+  case M.lookup (xRepr (Proxy :: Proxy a)) xs of
+    Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a))
+    Just (Left str) ->
+      let v = fromMaybe initialValue (demarshalExtension str)
+       in xput v >> return v
+    Nothing ->
+      xput (initialValue :: a) >> return initialValue
+
+xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b
+xgets fn = fn <$> xget
+
+-- State as it is marshalled. Used for derived instances of Show and Read.
 data MarshalledState
   = MarshalledState
       (StackSet ScreenId ScreenDetail Tag String Window)
@@ -247,42 +292,6 @@ marshalState
       doMarshalEx (Left s) = Just s
       doMarshalEx (Right (StateExtension a)) = marshalExtension a
 
--- | Puts a state extension.
-xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m ()
-xput val = liftW $ do
-  modify' $ \state@State {extensibleState = extensibleState} ->
-    state
-      { extensibleState =
-          M.insert
-            ( show $ someTypeRep (Proxy :: Proxy a)
-            )
-            (Right $ StateExtension val)
-            extensibleState
-      }
-
--- | Modifies a state extension.
-xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m ()
-xmodify fn = xput . fn =<< xget
-
--- | Modifies a state extension in the monadic context.
-xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m ()
-xmodifyM fn = (xput <=< fn) =<< xget
-
--- | Gets a state extension.
-xget :: forall a m. (ExtensionClass a, Wlike m) => m a
-xget = do
-  xs <- liftW $ gets extensibleState
-  case M.lookup (show $ someTypeRep (Proxy :: Proxy a)) xs of
-    Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a))
-    Just (Left str) ->
-      let v = fromMaybe initialValue (demarshalExtension str)
-       in xput v >> return v
-    Nothing ->
-      xput (initialValue :: a) >> return initialValue
-
-xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b
-xgets fn = fn <$> xget
-
 -- | Demarshals the string from "marshalState" into a state. Uses the provided
 -- config to fill out non-persistent parts of the state.
 demarshalState :: Config WindowLayout -> String -> State
diff --git a/src/Wetterhorn/Keys/Macros.hs b/src/Wetterhorn/Keys/Macros.hs
index 9af9827..de546f0 100644
--- a/src/Wetterhorn/Keys/Macros.hs
+++ b/src/Wetterhorn/Keys/Macros.hs
@@ -14,13 +14,7 @@ import Wetterhorn.Core.Keys
 import Wetterhorn.Core.W
 import Wetterhorn.Foreign.WlRoots (WlrInputDevice)
 
-data RecordedKey = RecordedKey
-  { recordedKeycode :: Word32,
-    recordedState :: KeyState,
-    recordedModifiers :: Word32,
-    recordedKeysym :: Word32,
-    recordedCodepoint :: Char
-  }
+data RecordedKey = RecordedKey Word32 KeyState Word32 Word32 Char
   deriving (Read, Show)
 
 data MacrosState = MacrosState
@@ -59,7 +53,7 @@ macroKeyBind = do
       stopMacroRecording
     Nothing -> do
       kp' <- nextKeyPress
-      liftIO $ printf "Recording %s" (show $ codepoint kp')
+      liftIO $ printf "Recording %s\n" (show $ codepoint kp')
       startMacroRecording (codepoint kp')
 
 replayMacroKeybind :: KeysM ()