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.

3 files changed, 219 insertions, 121 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 3e7e054..902e743 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 module Internal.Keys where
 
+import Internal.XPlus
 import Data.Maybe (isJust)
 import Debug.Trace
 import Control.Applicative
@@ -26,6 +27,8 @@ import XMonad.Util.Scratchpad
 import qualified Data.Map as Map
 import qualified XMonad.StackSet as W
 
+import Internal.Lib
+
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 
 applyKeys :: XConfig l -> IO (XConfig l)
@@ -34,119 +37,10 @@ applyKeys config@(XConfig {modMask = modm}) = do
    withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $
      config { keys = ks }
 
-newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a)
-
-data WinPrompt = WinPrompt
-
-instance XPrompt WinPrompt where
-    showXPrompt _ = "[Window] "
-    commandToComplete _ = id
-
-getHorizontallyOrderedScreens ::
-  W.StackSet wid l a ScreenId ScreenDetail ->
-    [W.Screen wid l a ScreenId ScreenDetail]
--- ^ Returns a list of screens ordered from leftmost to rightmost.
-getHorizontallyOrderedScreens windowSet =
-    flip sortBy screens $ \sc1 sc2 ->
-      let (SD (Rectangle x1 _ _ _)) = W.screenDetail sc1
-          (SD (Rectangle x2 _ _ _)) = W.screenDetail sc2
-          in x1 `compare` x2
-    where
-      screens = W.current windowSet : W.visible windowSet
-
 newKeys :: IO (KeyMap l)
 newKeys =
   withNewMarkContext $ \markContext ->
     return $ \config@(XConfig {modMask = modm}) ->
-      let workspacesByInt =
-            Map.fromList $
-              zip ['1'..] (XMonad.workspaces config)
-
-          gotoWorkspace ch = do
-            saveLastMark markContext
-            windows $ W.greedyView $ return ch
-
-          shiftToWorkspace ch = do
-            windows $ W.shift $ return ch
-
-          swapWs f t (W.Workspace t' l s) | t' == f = W.Workspace t l s
-          swapWs f t (W.Workspace t' l s) | t' == t = W.Workspace f l s
-          swapWs _ _ ws = ws
-
-          swapSc f t (W.Screen ws a b) = W.Screen (swapWs f t ws) a b
-
-          relativeWorkspaceShift :: Selector ->  X ()
-          relativeWorkspaceShift (Selector selector) = do
-            windows $ \ss -> do
-              let tags = sort $ (W.tag <$> filter (isJust . W.stack) (W.workspaces ss))
-                  from = W.tag $ W.workspace $ W.current ss
-                  to = selector from tags
-
-              W.greedyView to ss
-
-          nextWorkspace = Selector select
-            where select n (x:y:xs) | n == x = y
-                  select n (x:xs) = select n xs
-                  select n _ = n
-
-          prevWorkspace = Selector select
-            where select n (x:y:xs) | n == y = x
-                  select n (x:xs) = select n xs
-                  select n _ = n
-
-          swapWorkspace :: Char -> X ()
-          swapWorkspace toChar = do
-              windows $ \ss -> do
-                let from  = W.tag $ W.workspace $ W.current ss
-                    to = [toChar] in
-                  (W.StackSet (swapSc from to $ W.current ss)
-                              (map (swapSc from to) $ W.visible ss)
-                              (map (swapWs from to) $ W.hidden ss)
-                              (W.floating ss))
-
-          fuzzyCompletion s1 s0 =
-            let ws = filter (not . all isSpace) $ words (map toLower s1)
-                l0 = map toLower s0 in
-                 all (`isInfixOf`l0) ws
-
-          getString = runQuery $ do
-              t <- title
-              a <- appName
-              return $
-                if map toLower a `isInfixOf` map toLower t
-                  then t
-                  else printf "%s - %s" a t
-
-          withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
-          withScreen fn n = do
-            saveLastMark markContext
-            windows $ \windowSet ->
-              case (getHorizontallyOrderedScreens windowSet !! n) of
-                Nothing -> windowSet
-                Just screen -> fn (W.tag $ W.workspace screen) windowSet
-
-          windowJump = do
-              windowTitlesToWinId <- withWindowSet $ \ss ->
-                Map.fromList <$>
-                  mapM (\wid -> (,) <$> getString wid <*> return wid)
-                       (W.allWindows ss)
-
-              mkXPrompt
-                WinPrompt
-                xpConfig
-                (\input -> do
-                  return $ filter (fuzzyCompletion input) (Map.keys windowTitlesToWinId)) $ \str -> do
-                    saveLastMark markContext
-                    case Map.lookup str windowTitlesToWinId of
-                        Just w -> focus w
-                        Nothing ->
-                          case filter (fuzzyCompletion str) (Map.keys windowTitlesToWinId) of
-                              [s] ->
-                                mapM_ focus (Map.lookup s windowTitlesToWinId)
-                              _ -> return ()
-
-          in
-
       Map.fromList
         [ ((modm, xK_F12), (void $ spawn "spotify-control next"))
         , ((modm, xK_F11), (void $ spawn "spotify-control prev"))
@@ -160,15 +54,24 @@ newKeys =
         , ((modm .|. shiftMask, xK_t), withFocused $ windows . W.sink)
         , ((modm, xK_t),  (void $ spawn (terminal config)))
         , ((modm, xK_m), (submap $ mapAlpha modm (markCurrentWindow markContext)))
-        , ((modm, xK_w), windowJump)
+        , ((modm, xK_w), runXPlus markContext config windowJump)
         , ((modm, xK_apostrophe), (submap $
               Map.insert
                 (modm, xK_apostrophe)
                 (jumpToLast markContext)
                 (mapAlpha modm (jumpToMark markContext))))
-        , ((modm, xK_g), (submap $ mapNumbersAndAlpha 0 gotoWorkspace))
-        , ((modm .|. shiftMask, xK_g), (submap $ mapNumbersAndAlpha 0 shiftToWorkspace))
-        , ((modm .|. shiftMask .|. mod1Mask, xK_g), (submap $ mapNumbersAndAlpha 0 swapWorkspace))
+
+        , ((modm, xK_g), (submap $
+            mapNumbersAndAlpha 0 (
+              runXPlus markContext config . gotoWorkspace)))
+
+        , ((modm .|. shiftMask, xK_g), (submap $
+            mapNumbersAndAlpha 0 (
+              runXPlus markContext config . shiftToWorkspace)))
+
+        , ((modm .|. shiftMask .|. mod1Mask, xK_g), (submap $
+            mapNumbersAndAlpha 0 (
+              runXPlus markContext config . swapWorkspace)))
 
         , ((modm .|. shiftMask, xK_bracketleft), sendMessage (IncMasterN (-1)))
         , ((modm .|. shiftMask, xK_bracketright), sendMessage (IncMasterN 1))
@@ -177,8 +80,8 @@ newKeys =
 
         , ((modm, xK_space), sendMessage NextLayout)
 
-        , ((modm, xK_n), relativeWorkspaceShift nextWorkspace)
-        , ((modm, xK_p), relativeWorkspaceShift prevWorkspace)
+        , ((modm, xK_n), relativeWorkspaceShift next)
+        , ((modm, xK_p), relativeWorkspaceShift prev)
 
         , ((modm, xK_q), spawn "xmonad --recompile && xmonad --restart")
         , ((modm, xK_z), sendMessage ToggleZoom)
@@ -186,13 +89,18 @@ newKeys =
         , ((modm, xK_Tab), windows W.focusDown)
         , ((modm .|. shiftMask, xK_Tab), windows W.focusUp)
 
-        , ((modm, xK_a), withScreen W.view 0)
-        , ((modm, xK_o), withScreen W.view 1)
-        , ((modm, xK_e), withScreen W.view 2)
+        , ((modm, xK_a), runXPlus markContext config (withScreen W.view 0))
+        , ((modm, xK_o), runXPlus markContext config (withScreen W.view 1))
+        , ((modm, xK_e), runXPlus markContext config (withScreen W.view 2))
+
+        , ((modm .|. shiftMask, xK_a), runXPlus markContext config (withScreen W.shift 0))
+        , ((modm .|. shiftMask, xK_o), runXPlus markContext config (withScreen W.shift 1))
+        , ((modm .|. shiftMask, xK_e), runXPlus markContext config (withScreen W.shift 2))
 
-        , ((modm .|. shiftMask, xK_a), withScreen W.shift 0)
-        , ((modm .|. shiftMask, xK_o), withScreen W.shift 1)
-        , ((modm .|. shiftMask, xK_e), withScreen W.shift 2)
+        -- Buttons programmed on my mouse.
+        , ((shiftMask, xK_F1), withFocused $ windows . W.sink)
+        , ((shiftMask, xK_F2), kill)
+        , ((shiftMask, xK_F3), kill)
         ]
 
 mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> Map (KeyMask, KeySym) (X ())
diff --git a/src/Internal/Lib.hs b/src/Internal/Lib.hs
new file mode 100644
index 0000000..e0b78c5
--- /dev/null
+++ b/src/Internal/Lib.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE RankNTypes #-}
+module Internal.Lib where
+
+import Prelude hiding ((!!))
+
+import XMonad.Prompt
+import XMonad.Prompt.Input
+import XMonad.Prompt.Shell
+
+import Internal.PromptConfig
+
+import Data.Char
+import Data.List hiding ((!!))
+import Data.List.Safe ((!!))
+import Data.Maybe
+import Internal.Marking
+import Internal.XPlus
+import Text.Printf
+import XMonad hiding (workspaces, Screen)
+import XMonad.StackSet hiding (filter, focus)
+import qualified Data.Map as Map
+
+type WorkspaceName = Char
+newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a)
+
+data WinPrompt = WinPrompt
+
+instance XPrompt WinPrompt where
+    showXPrompt _ = "[Window] "
+    commandToComplete _ = id
+
+getHorizontallyOrderedScreens ::
+  StackSet wid l a ScreenId ScreenDetail ->
+    [Screen wid l a ScreenId ScreenDetail]
+-- ^ Returns a list of screens ordered from leftmost to rightmost.
+getHorizontallyOrderedScreens windowSet =
+    flip sortBy screens $ \sc1 sc2 ->
+      let (SD (Rectangle x1 _ _ _)) = screenDetail sc1
+          (SD (Rectangle x2 _ _ _)) = screenDetail sc2
+          in x1 `compare` x2
+    where
+      screens = current windowSet : visible windowSet
+
+
+gotoWorkspace :: WorkspaceName -> XPlus l ()
+gotoWorkspace ch = do
+  mc <- getMarkContext
+  liftXPlus $ do
+    saveLastMark mc
+    windows $ greedyView $ return ch
+
+shiftToWorkspace :: WorkspaceName -> XPlus l ()
+shiftToWorkspace = liftXPlus . windows . shift . return
+
+swapWorkspace :: WorkspaceName -> XPlus l ()
+swapWorkspace toWorkspaceName = liftXPlus $ do
+  windows $ \ss -> do
+    let fromWorkspace = tag $ workspace $ current ss
+        toWorkspace = [toWorkspaceName] in
+      (StackSet (swapSc fromWorkspace toWorkspace $ current ss)
+                (map (swapSc fromWorkspace toWorkspace) $ visible ss)
+                (map (swapWs fromWorkspace toWorkspace) $ hidden ss)
+                (floating ss))
+  where
+    swapSc fromWorkspace toWorkspace (Screen ws a b) =
+        Screen (swapWs fromWorkspace toWorkspace ws) a b
+
+    swapWs fromWorkspace toWorkspace ws@(Workspace t' l s)
+        | t' == fromWorkspace = Workspace toWorkspace l s
+        | t' == toWorkspace = Workspace fromWorkspace l s
+        | otherwise = ws
+
+fuzzyCompletion :: String -> String -> Bool
+fuzzyCompletion str0 str1 =
+  all (`isInfixOf`l0) ws
+  where
+    ws = filter (not . all isSpace) $ words (map toLower str0)
+    l0 = map toLower str1
+
+getString :: Window -> X String
+getString = runQuery $ do
+  t <- title
+  a <- appName
+  return $
+    if map toLower a `isInfixOf` map toLower t
+      then t
+      else printf "%s - %s" t a
+
+relativeWorkspaceShift :: Selector -> X ()
+relativeWorkspaceShift (Selector selector) = do
+  windows $ \ss ->
+    let tags = sort $ (tag <$> filter (isJust . stack) (workspaces ss))
+        from = tag $ workspace $ current ss
+        to = selector from tags
+    in greedyView to ss
+
+next :: Selector
+next = Selector $ \a l -> select a l l
+  where select n (x:y:xs) _ | n == x = y 
+        select n [x] (y:_) | n == x = y
+        select n (x:xs) orig = select n xs orig
+        select n _ _ = n
+
+prev :: Selector
+prev = Selector $ \a l ->
+  let (Selector fn) = next in fn a (reverse l)
+
+withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> XPlus l ()
+withScreen fn n = do
+  markContext <- getMarkContext
+
+  liftXPlus $
+    windows $ \windowSet ->
+      case (getHorizontallyOrderedScreens windowSet !! n) of
+        Nothing -> windowSet
+        Just screen -> fn (tag $ workspace screen) windowSet
+
+windowJump :: XPlus l ()
+windowJump = do
+  markContext <- getMarkContext
+
+  liftXPlus $ do
+    windowTitlesToWinId <- withWindowSet $ \ss ->
+      Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss)
+
+    mkXPrompt
+      WinPrompt
+      xpConfig
+      (\input -> return $ filter (fuzzyCompletion input) (Map.keys windowTitlesToWinId)) $
+      \str -> do
+        saveLastMark markContext
+        case Map.lookup str windowTitlesToWinId of
+          Just w -> focus w
+          Nothing ->
+            case filter (fuzzyCompletion str) (Map.keys windowTitlesToWinId) of
+              [s] -> mapM_ focus (Map.lookup s windowTitlesToWinId)
+              _ -> return ()
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