From e57b0a3a870d1f9688491b17afbd5a9d994ad343 Mon Sep 17 00:00:00 2001
From: Josh Rahm <rahm@google.com>
Date: Thu, 26 Mar 2020 16:21:29 -0600
Subject: Move logic from Keys.hs to Lib.hs.

Added an monad XPlus that holds extra state with the
MarkContext, etc. This should make it easier to handle
as more and more state accrues over time.
---
 src/Internal/XPlus.hs | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 src/Internal/XPlus.hs

(limited to 'src/Internal/XPlus.hs')

diff --git a/src/Internal/XPlus.hs b/src/Internal/XPlus.hs
new file mode 100644
index 0000000..c546665
--- /dev/null
+++ b/src/Internal/XPlus.hs
@@ -0,0 +1,53 @@
+module Internal.XPlus where
+
+import Internal.Marking
+import XMonad
+
+-- The X Monad with additional information. Used for configuring the system.
+
+data XPlusState l =
+    XPlusState {
+      markContext :: MarkContext
+    , xConfig :: XConfig l
+    }
+
+data XPlus l a = XPlus (XPlusState l -> X (a, XPlusState l))
+
+instance Functor (XPlus l) where
+  fmap fn (XPlus xfn) =
+    XPlus $ \st -> do
+      (a, b) <- xfn st
+      return (fn a, b)
+
+instance Applicative (XPlus l) where
+  pure = return
+  (<*>) afn aarg = do
+    fn <- afn
+    arg <- aarg
+    return (fn arg)
+
+instance Monad (XPlus l) where
+   -- (>>=) :: XPlus l a -> (a -> XPlus l b) -> XPlus l b
+    (>>=) (XPlus afn) bfn = do
+       XPlus $ \s0 -> do
+         (a, s1) <- afn s0
+         let (XPlus xBFn) = bfn a
+         xBFn s1
+
+    return x = XPlus $ \s -> return (x, s)
+
+getXPlusState :: XPlus l (XPlusState l)
+getXPlusState = XPlus $ \s -> return (s, s)
+
+getXConfig :: XPlus l (XConfig l)
+getXConfig = xConfig <$> getXPlusState
+
+getMarkContext :: XPlus l MarkContext
+getMarkContext = markContext <$> getXPlusState
+
+runXPlus :: MarkContext -> XConfig l -> XPlus l a -> X a
+runXPlus markCtx cfg (XPlus fn) = do
+  fst <$> fn (XPlusState markCtx cfg)
+
+liftXPlus :: X a -> XPlus l a
+liftXPlus xa = XPlus $ \s -> (\a -> (a, s)) <$> xa
-- 
cgit