Overhaul how Wml is implemented.

This adds a new "KeyFeed" monad which is reminiscent of a parsec-type
monad. This allows keys like 'g' to be mapped using a subbind and the
actual WML part be handled in the catch-all handler.

This also significantly cleans up the typing and complexity of the Wml
implementation.

1 files changed, 109 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/Keys/KeyFeed.hs b/src/Rahm/Desktop/Keys/KeyFeed.hs
new file mode 100644
index 0000000..c7b08e1
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/KeyFeed.hs
@@ -0,0 +1,109 @@
+-- Module for the KeyFeed monad.
+--
+-- The KeyFeed Monad abstracts control flow over a stream of key presses in RDE.
+module Rahm.Desktop.Keys.KeyFeed where
+
+import Control.Monad (void, when)
+import Control.Monad.State (MonadTrans (lift), StateT, evalStateT, modify')
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
+import Data.List.Safe (head, last)
+import Rahm.Desktop.Common (Xish (..))
+import Rahm.Desktop.Submap (mapNextStringWithKeysym)
+import Rahm.Desktop.XMobarLog.PendingBuffer (addStringToPendingBuffer, pushAddPendingBuffer, pushPendingBuffer)
+import XMonad
+import Prelude hiding (head, last)
+
+-- A key is a mask and a keysym. The string is the string returned from
+-- XLookupString.
+type Key = (KeyMask, KeySym, String)
+
+-- A list of keys
+type KeyString = [Key]
+
+-- List of actions which return a key.
+type KeyStream = [MaybeT X Key]
+
+newtype KeyFeed a = KeyFeed (StateT KeyStream (MaybeT X) a)
+  deriving (Functor, Applicative, Monad)
+
+instance Xish KeyFeed where
+  liftFromX = liftXToFeed
+
+-- Executes a KeyFeed, returning a MaybeT of the result
+runKeyFeed :: KeyFeed a -> MaybeT X a
+runKeyFeed = runKeyFeedWithStartingKeys []
+
+-- Executes a KeyFeed, evaluating down to an X (Maybe a)
+runKeyFeedX :: KeyFeed a -> X (Maybe a)
+runKeyFeedX = runMaybeT . runKeyFeed
+
+-- Exceutes a KeyFeed. Does not evaluate the results.
+execKeyFeed :: KeyFeed a -> X ()
+execKeyFeed = void . runMaybeT . runKeyFeed
+
+-- Executes a KeyFeed, evaluating the keystring first, then evaluating actual
+-- key presses.
+runKeyFeedWithStartingKeys :: KeyString -> KeyFeed a -> MaybeT X a
+runKeyFeedWithStartingKeys st (KeyFeed r) =
+  evalStateT r $
+    (map return st ++) $
+      repeat $ do
+        mapNextStringWithKeysym $ \m s st -> return (m, s, st)
+
+-- Executes a KeyFeed only on the given key presses.
+runKeyFeedWithKeys :: KeyString -> KeyFeed a -> MaybeT X a
+runKeyFeedWithKeys st (KeyFeed r) = evalStateT r (toKeyStream st)
+
+-- Executes a function on the next key read and returns the result.
+readNextKey :: ((KeyMask, KeySym, String) -> KeyFeed a) -> KeyFeed a
+readNextKey fn = KeyFeed $ do
+  keyList <- get
+  nextKeyFn <- upMaybe $ head keyList
+  nextKey@(_, sym, str) <- lift nextKeyFn
+
+  -- escape always ends a key feed.
+  when (sym == xK_Escape) $ do
+    let (KeyFeed r) = feedFail in r
+
+  modify' tail
+  let (KeyFeed r) = liftFromX (addStringToPendingBuffer str) >> fn nextKey in r
+  where
+    upMaybe :: Maybe a -> StateT KeyStream (MaybeT X) a
+    upMaybe m = lift $ MaybeT (return m)
+
+-- Lifts a Maybe int o a KeyFeed.
+hoistMaybe :: Maybe a -> KeyFeed a
+hoistMaybe = KeyFeed . lift . MaybeT . return
+
+-- Lifts a Maybe int o a KeyFeed.
+hoistMaybeT :: MaybeT X a -> KeyFeed a
+hoistMaybeT = KeyFeed . lift
+
+-- Fails a KeyFeed action.
+feedFail :: KeyFeed a
+feedFail = KeyFeed $ lift (MaybeT $ return Nothing)
+
+-- Lifts an X action into a KeyFeed action.
+liftXToFeed :: X a -> KeyFeed a
+liftXToFeed = KeyFeed . lift . lift
+
+-- Lifts an X action into a KeyFeed action.
+liftXMaybe :: X (Maybe a) -> KeyFeed a
+liftXMaybe = KeyFeed . lift . MaybeT
+
+-- Removes a maybe and pushes it into the KeyFeed monad. If the maybe is
+-- Nothing, the KeyFeed fails.
+absorbMaybe :: KeyFeed (Maybe a) -> KeyFeed a
+absorbMaybe fn = hoistMaybe =<< fn
+
+-- Inserts keys to the beginnig of the KeyFeed buffer.
+pushKeys :: KeyString -> KeyFeed ()
+pushKeys ks = KeyFeed $ modify' (map return ks ++)
+
+-- Inserts a single key to the beginning of the KeyFeed buffer.
+pushKey :: (KeyMask, KeySym, String) -> KeyFeed ()
+pushKey = pushKeys . (: [])
+
+-- Converts a string of keys to a stream of keys.
+toKeyStream :: KeyString -> KeyStream
+toKeyStream = map return