Add basic language for moving windows around

6 files changed, 242 insertions, 132 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 926d5ff..5a5aecf 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -2,6 +2,7 @@ module Rahm.Desktop.Common where
 
 import Prelude hiding ((!!))
 
+import Control.Monad (void)
 import Control.Monad.Trans.Maybe
 import XMonad.Actions.DynamicWorkspaces
 import XMonad.Util.Run
@@ -42,6 +43,14 @@ masterWindow = MaybeT $ withWindowSet $ \ss ->
       (a:_) -> return $ Just a
       _ -> return Nothing
 
+windowsInWorkspace :: WorkspaceId -> X [Location]
+windowsInWorkspace wid =
+  withWindowSet $
+    return . concatMap (\ws ->
+      if S.tag ws == wid
+        then map (Location wid . Just) $ S.integrate' (S.stack ws)
+        else []) . S.workspaces
+
 data WinPrompt = WinPrompt
 
 instance XPrompt WinPrompt where
@@ -84,3 +93,11 @@ getCurrentWorkspace = withWindowSet $
   \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do
     return t
 
+getCurrentLocation :: X Location
+getCurrentLocation = do
+  ws <- getCurrentWorkspace
+  win <- withWindowSet (return . peek)
+  return (Location ws win)
+
+runMaybeT_ :: (Monad m) => MaybeT m a -> m ()
+runMaybeT_  = void . runMaybeT
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 1369a17..23927ef 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -1,5 +1,6 @@
 module Rahm.Desktop.Keys (applyKeys) where
 
+import Control.Monad.Trans.Maybe
 import Control.Applicative
 import Control.Monad
 import Control.Monad.Fix (fix)
@@ -11,7 +12,7 @@ import Data.Char
 import Data.List hiding ((!!))
 import Data.List.Safe ((!!))
 import Data.Map (Map)
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe (isJust, fromMaybe, mapMaybe)
 import Data.Monoid (Endo(..))
 import Debug.Trace
 import Graphics.X11.ExtraTypes.XF86;
@@ -51,6 +52,7 @@ import Rahm.Desktop.Layout.Rotate (rotateLayout)
 import Rahm.Desktop.Common
 import Rahm.Desktop.Logger
 import Rahm.Desktop.Marking
+import Rahm.Desktop.Lang
 import Rahm.Desktop.MouseMotion
 import Rahm.Desktop.PassMenu
 import Rahm.Desktop.PromptConfig
@@ -141,13 +143,11 @@ keymap = runKeys $ do
   bind xK_apostrophe $ do
     justMod $
       doc "Jumps between marks." $
-      mapNextString $ const (mapM_ focusLocation <=< markToLocation)
-
-    shiftMod $
-      doc "Move the marked window to the current workspace." $
-      mapNextString $ \_ str -> do
-        mapM_ (\loc -> moveLocationToWorkspace loc <$> getCurrentWorkspace)
-          =<< markToLocation str
+      runMaybeT_ $ do
+        l <- readNextLocationSet
+        case l of
+          (h:_) -> lift (focusLocation h)
+          _ -> return ()
 
   bind xK_BackSpace $ do
     -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if
@@ -279,50 +279,23 @@ keymap = runKeys $ do
          \_: Black hole. Sending a window here closes it.\n\n\t\
       \Other keybindings starting with H-g\n\t\t\
          \F1: display this help.\n\n\t" $
-      mapNextStringWithKeysym $ \_ keysym str ->
-        case ((keysym, str), selectWorkspace str) of
-          (_, Just w) -> gotoWorkspace =<< w
-          -- Test binding. Tests that I can still submap keysyms alone (keys
-          -- where XLookupString won't return anything helpful.)
-          ((f, _), _) | f == xK_F1 ->
-            (safeSpawn "gxmessage" [
-              "-fn", "Source Code Pro",
-              documentation (keymap config)] :: X ())
-          _ -> return ()
+      runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace
 
     shiftMod $
       doc "Move the currently focused window to another workspace" $
-      mapNextStringWithKeysym $ \_ keysym str ->
-        case ((keysym, str), selectWorkspace str) of
-          (_, Just w) -> shiftToWorkspace =<< w
-          ((_, "_"), _) -> CopyWindow.kill1
-          _ -> return ()
+      runMaybeT_ $ do
+        ws <- readNextWorkspace
+        loc <- lift getCurrentLocation
+        lift $ moveLocationToWorkspaceFn ws loc
 
     controlMod $
       doc "Move the current focused window to another workspace and view that workspace" $
-      mapNextStringWithKeysym $ \_ keysym str ->
-        case ((keysym, str), selectWorkspace str) of
-          (_, Just w) -> do
-            ws <- w
-            shiftToWorkspace ws
-            gotoWorkspace ws
-          _ -> return ()
-
-    altMod $
-      doc "Copy a window to the given workspace" $
-      mapNextStringWithKeysym $ \_ keysym str ->
-        case ((keysym, str), selectWorkspace str) of
-          (_, Just ws) -> windows . CopyWindow.copy =<< ws
-          _ -> return ()
-
-    shiftAltMod $
-      doc "Swap this workspace with another workspace (rename)." $
-      mapNextStringWithKeysym $ \_ keysym str ->
-        case ((keysym, str), selectWorkspace str) of
-          (_, Just ws) -> swapWorkspace =<< ws
-          ((_, "_"), _) ->
-            mapM_ (\w -> focus w >> CopyWindow.kill1) =<< windowsInCurrentWorkspace
-          _ -> return ()
+      runMaybeT_ $ do
+        ws <- readNextWorkspace
+        loc <- lift getCurrentLocation
+        lift $ do
+          moveLocationToWorkspaceFn ws loc
+          gotoWorkspaceFn ws
 
   bind xK_h $ do
     justMod $
@@ -382,7 +355,7 @@ keymap = runKeys $ do
   bind xK_m $ do
     justMod $
       doc "Mark the current window with the next typed character." $
-      mapNextString $ \_ str ->
+      runMaybeT_ $ mapNextString $ \_ str -> lift $
         case str of
           [ch] | isAlpha ch -> markCurrentWindow str
           _ -> return ()
@@ -417,16 +390,19 @@ keymap = runKeys $ do
       sendMessage rotateLayout
 
   bind xK_s $ do
-    justMod $
-      mapNextString $ \_ mark -> do
-        loc' <- markToLocation mark
-        case loc' of
-          Nothing -> return ()
-          Just loc -> do
-            mapM_ setAlternateWindow (locationWindow loc)
-            mapNextString $ \_ ws -> do
-              mapM_ (moveLocationToWorkspace loc=<<) (selectWorkspace ws)
+    justMod $ runMaybeT_ $ do
+      locations <- readNextLocationSet 
+
+      workspace <- readNextWorkspace
+      mapM_ (lift . moveLocationToWorkspaceFn workspace) locations
 
+      lift $ setAlternateWindows (mapMaybe locationWindow locations)
+      forM_ locations $ \loc ->
+        case locationWindow loc of
+          Nothing -> return ()
+          Just win -> do
+            lift $ logs $ printf "setAlternate %s %s" (show win) (show $ locationWorkspace loc)
+            lift $ setAlternateWorkspace win (locationWorkspace loc)
 
     altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
 
diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs
new file mode 100644
index 0000000..374500d
--- /dev/null
+++ b/src/Rahm/Desktop/Lang.hs
@@ -0,0 +1,127 @@
+module Rahm.Desktop.Lang where
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+
+import Data.Char (isAlphaNum, isAlpha, isDigit, ord)
+import XMonad.Actions.CopyWindow as CopyWindow
+import XMonad.Util.Run (safeSpawn)
+import qualified XMonad.StackSet as W
+
+import Rahm.Desktop.Common
+import Rahm.Desktop.Keys.Dsl
+import Rahm.Desktop.History
+import Rahm.Desktop.Marking
+import Rahm.Desktop.Workspaces
+import Rahm.Desktop.Submap
+import Rahm.Desktop.Logger
+
+import Text.Printf
+
+import XMonad
+
+data Workspace =
+  Workspace {
+    moveLocationToWorkspaceFn :: Location -> X ()
+  , gotoWorkspaceFn :: X ()
+  , workspaceName :: String
+  }
+
+justWorkspace :: String -> Workspace
+justWorkspace s =
+  Workspace {
+    moveLocationToWorkspaceFn = flip moveLocationToWorkspace s
+  , gotoWorkspaceFn = gotoWorkspace s
+  , workspaceName = s
+  }
+
+blackHoleWorkspace :: Workspace
+blackHoleWorkspace =
+  Workspace {
+    moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow
+  , gotoWorkspaceFn = return () -- can't navigate to black hole
+  , workspaceName = "blackhole"
+  }
+
+alternateWorkspace :: Workspace
+alternateWorkspace =
+  Workspace {
+    moveLocationToWorkspaceFn  = \l@(Location _ maybeWin) -> do
+      logs $ "Moving Location: " ++ show l
+      case maybeWin of
+        Nothing -> return ()
+        Just win -> do
+          alter <- getAlternateWorkspace win
+          logs $ printf "Moving %s to %s" (show win) (show alter)
+          mapM_ (moveLocationToWorkspace l) alter
+
+  , gotoWorkspaceFn = do
+      (Location _ maybeWin) <- getCurrentLocation
+      case maybeWin of
+        Nothing -> return ()
+        Just win -> do
+          mapM_ gotoWorkspace =<<  getAlternateWorkspace win
+
+  , workspaceName = "@"
+  }
+
+readNextWorkspace :: MaybeT X Workspace
+readNextWorkspace =
+  mapNextStringWithKeysym $ \mask sym str ->
+    case (mask, sym, str) of
+      (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
+      (_, _, "[") -> lift $ 
+        justWorkspace <$>
+          (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace)
+      (_, _, "]") -> lift $
+        justWorkspace <$>
+          (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace)
+      (_, _, "(") -> lift $ 
+        justWorkspace <$>
+          (adjacentWorkspace prev =<< getCurrentWorkspace)
+      (_, _, ")") -> lift $
+        justWorkspace <$>
+          (adjacentWorkspace next =<< getCurrentWorkspace)
+      (_, _, "}") -> lift $ justWorkspace <$> adjacentScreen next
+      (_, _, "{") -> lift $ justWorkspace <$> adjacentScreen prev
+      (_, _, "^") -> lift $ justWorkspace <$> firstWorkspaceId
+      (_, _, "'") -> justWorkspace . locationWorkspace <$> MaybeT lastLocation
+      (_, _, ".") -> lift $ justWorkspace <$> getCurrentWorkspace
+      (_, _, "$") -> lift $ justWorkspace <$> lastWorkspaceId
+      (_, _, "/") -> do
+        justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId)
+      (_, _, " ") -> lift $
+        justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
+      (_, _, "_") -> return blackHoleWorkspace
+      (_, _, "-") -> return alternateWorkspace
+      _ -> MaybeT (return Nothing)
+
+readNextLocationSet :: MaybeT X [Location]
+readNextLocationSet =
+  mapNextStringWithKeysym $ \mask sym str ->
+    case (mask, sym, str) of
+      (_, _, [ch]) | isAlpha ch -> lift $ getMarkedLocations [ch]
+      (_, _, "0") -> (:[]) <$> MaybeT getMostRecentLocationInHistory
+      (_, _, [ch]) | isDigit ch ->
+        (:[]) <$> MaybeT (pastHistory (ord ch - 0x30))
+      (_, _, ".") -> (:[]) <$> lift getCurrentLocation
+      (_, _, "^") -> (:[]) <$> farLeftWindow
+      (_, _, "$") -> (:[]) <$> farRightWindow
+      (_, _, "\"") -> (:[]) <$> MaybeT nextLocation
+      (_, _, "'") -> (:[]) <$>  MaybeT lastLocation
+      (_, _, "*") -> (:[]) <$> (windowLocation =<< masterWindow)
+      (_, _, "-") -> mapM windowLocation =<< lift getAlternateWindows
+      (_, _, "/") -> (:[]) <$> (windowLocation =<< MaybeT askWindowId)
+      (_, _, "%") ->
+        mapM windowLocation =<< lift (withWindowSet (return . W.allWindows))
+      (_, _, "@") -> (lift . windowsInWorkspace . workspaceName) =<< readNextWorkspace
+      (_, _, "&") -> do
+        l1 <- readNextLocationSet
+        l2 <- readNextLocationSet
+        return (l1 ++ l2)
+      (_, _, "\\") -> do
+        l1 <- readNextLocationSet
+        l2 <- readNextLocationSet
+        return $ filter (not . flip elem l2) l1
+        
+      _ -> MaybeT (return Nothing)
diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs
index 5caaa3b..f4e0d9a 100644
--- a/src/Rahm/Desktop/Marking.hs
+++ b/src/Rahm/Desktop/Marking.hs
@@ -1,18 +1,29 @@
 module Rahm.Desktop.Marking (
   markCurrentWindow,
   jumpToMark,
-  markToLocation,
   moveLocationToWorkspace,
-  setAlternateWindow,
-  getAlternateWindow
+  setAlternateWindows,
+  getAlternateWindows,
+  setAlternateWorkspace,
+  getAlternateWorkspace,
+  getMarkedLocations,
+  farLeftWindow,
+  farRightWindow,
+  windowLocation
   ) where
+
+import Prelude hiding (head)
+
+import Data.Maybe (fromMaybe)
+import Control.Monad.Trans (lift)
 import Data.Ord (Down(..))
 import Control.Exception
-import Control.Monad (when)
+import Control.Monad (when, (<=<))
 import Control.Monad.Trans.Maybe
 import Data.Char (isAlpha, isDigit, ord)
 import Data.IORef
 import Data.List (sortOn, sort, sortBy, find)
+import Data.List.Safe (head)
 import Data.Map (Map)
 import Data.Maybe (catMaybes)
 import Data.Sequence (Seq(..))
@@ -36,13 +47,14 @@ type Mark = String
 
 data MarkState =
   MarkState {
-    markStateMap :: Map Mark Location
-  , alternateWindow :: Maybe Window
+    markStateMap :: Map Mark [Location]
+  , alternateWindows :: [Window]
+  , alternateWorkspaces :: Map Window WorkspaceId
   } deriving (Read, Show)
 
 
 instance ExtensionClass MarkState where
-  initialValue = MarkState Map.empty Nothing
+  initialValue = MarkState Map.empty [] Map.empty
   extensionType = PersistentExtension
 
 -- greedyFocus :: Window -> X ()
@@ -53,19 +65,24 @@ instance ExtensionClass MarkState where
 --     mapM_ (windows . greedyView . tag) ws
 --     focus win
 
-setAlternateWindow :: Window -> X ()
-setAlternateWindow win = XS.modify (\m -> m { alternateWindow = Just win }) 
+setAlternateWorkspace :: Window -> WorkspaceId -> X ()
+setAlternateWorkspace win wid =
+  XS.modify $ \m -> m {
+      alternateWorkspaces = Map.insert win wid (alternateWorkspaces m)
+    }
 
-getAlternateWindow :: MaybeT X Window
-getAlternateWindow = MaybeT $ alternateWindow <$> XS.get
+getAlternateWorkspace :: Window -> X (Maybe WorkspaceId)
+getAlternateWorkspace window =
+  Map.lookup window . alternateWorkspaces <$> XS.get
 
-withMaybeFocused :: (Maybe Window -> X a) -> X a
-withMaybeFocused f = withWindowSet $ f . peek
+setAlternateWindows :: [Window] -> X ()
+setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) 
 
-getCurrentLocation :: X Location
-getCurrentLocation =
-  (\ws -> withMaybeFocused (return . Location ws)) =<< getCurrentWorkspace
+getAlternateWindows :: X [Window]
+getAlternateWindows = alternateWindows <$> XS.get
 
+withMaybeFocused :: (Maybe Window -> X a) -> X a
+withMaybeFocused f = withWindowSet $ f . peek
 
 markCurrentWindow :: Mark -> X ()
 markCurrentWindow mark = do
@@ -74,13 +91,18 @@ markCurrentWindow mark = do
   withFocused $ \win ->
     XS.modify $ \state@MarkState {markStateMap = ms} ->
         state {
-          markStateMap = Map.insert mark (Location ws $ Just win) ms
+          markStateMap = Map.insertWith (++) mark [Location ws $ Just win] ms
         }
 
 jumpToMark :: Mark -> X ()
 jumpToMark mark = do
   MarkState {markStateMap = m} <- XS.get
-  mapM_ focusLocation $ Map.lookup mark m
+  mapM_ focusLocation $ head =<< Map.lookup mark m
+
+getMarkedLocations :: Mark -> X [Location]
+getMarkedLocations mark = do
+  MarkState {markStateMap = m} <- XS.get
+  return (fromMaybe [] $ Map.lookup mark m)
 
 setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd
 setFocusedWindow
@@ -122,30 +144,16 @@ windowLocation win = do
   tag <- MaybeT $ withWindowSet $ return . findTag win
   return (Location tag (Just win))
 
-markToLocation :: Mark -> X (Maybe Location)
-markToLocation mark =
-  case mark of
-    [ch] | isAlpha ch -> Map.lookup mark . markStateMap <$> XS.get
-    "0" -> getMostRecentLocationInHistory
-    [ch] | isDigit ch -> pastHistory (ord ch - 0x30)
-    "." -> Just <$> getCurrentLocation
-    "\"" -> nextLocation
-    "'" -> lastLocation
-    "/" -> runMaybeT $ windowLocation =<< MaybeT askWindowId
-    "^" -> do
-          rects <- sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects
-          case rects of
-            ((w, _) : _) -> runMaybeT (windowLocation w)
-            _ -> return Nothing
-    "$" -> do
-          rects <- sortOn (Down . \(_, Rectangle x _ _ _) -> x)
-                     <$> getWindowsAndRects
-          case rects of
-            ((w, _) : _) -> runMaybeT (windowLocation w)
-            _ -> return Nothing
-
-    "*" -> runMaybeT (windowLocation =<< masterWindow)
-
-    "@" -> runMaybeT (windowLocation =<< getAlternateWindow)
-
-    _ -> return Nothing
+farLeftWindow :: MaybeT X Location
+farLeftWindow = do
+  rects <- lift $ sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects
+  case rects of
+    ((w, _) : _) -> windowLocation w
+    _ -> MaybeT (return Nothing)
+
+farRightWindow :: MaybeT X Location
+farRightWindow = do
+  rects <- lift $ sortOn (Down . \(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects
+  case rects of
+    ((w, _) : _) -> windowLocation w
+    _ -> MaybeT (return Nothing)
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index 5db8928..48a3144 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -9,6 +9,10 @@ module Rahm.Desktop.Submap (
     submapDefault,
     submapDefaultWithKey) where
 
+import Rahm.Desktop.Common
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans
+import Control.Monad (void)
 import XMonad hiding (keys)
 import Control.Monad.Fix (fix)
 import qualified Data.Map as Map
@@ -54,7 +58,8 @@ getMaskEventWithTimeout timeout d mask fn = do
  - but also allows submappings for keys that may not have a character associated
  - with them (for example, the function keys).
  -}
-mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X ()
+mapNextStringWithKeysym ::
+  (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a
 mapNextStringWithKeysym fn = do
   XConf { theRoot = root, display = d } <- ask
   io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
@@ -76,17 +81,18 @@ mapNextStringWithKeysym fn = do
       Nothing -> return Nothing
 
   io $ ungrabKeyboard d currentTime
-  case ret of
-    Just (m, str, keysym) -> fn m keysym str
-    Nothing -> return ()
+
+  (m, str, keysym) <- MaybeT $ return ret
+  fn m keysym str
 
 {- Like submap, but on the character typed rather than the kysym. -}
-mapNextString :: (KeyMask -> String -> X ()) -> X ()
+mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a
 mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
 
 submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X ()
-submapDefaultWithKey def m = mapNextStringWithKeysym $ \mask sym _ -> do
-  Map.findWithDefault (def (mask, sym)) (mask, sym) m
+submapDefaultWithKey def m = runMaybeT_ $
+  mapNextStringWithKeysym $ \mask sym _ -> lift $ do
+     Map.findWithDefault (def (mask, sym)) (mask, sym) m
 
 submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X ()
 submapDefault def = submapDefaultWithKey (const def)
diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs
index 3a26823..f11520a 100644
--- a/src/Rahm/Desktop/Workspaces.hs
+++ b/src/Rahm/Desktop/Workspaces.hs
@@ -147,27 +147,3 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) ->
     W.tag <$>
       find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack)
         (map W.workspace (c : v) ++ h)
-
-selectWorkspace :: String -> Maybe (X WorkspaceId)
-selectWorkspace s = case s of
-  [ch] | isAlphaNum ch || ch == '*' -> Just $ return [ch]
-  "]" -> Just $ adjacentWorkspaceNotVisible next
-                  =<< getCurrentWorkspace
-  "[" -> Just $ adjacentWorkspaceNotVisible prev
-                  =<< getCurrentWorkspace
-  ")" -> Just $ adjacentWorkspace next =<< getCurrentWorkspace
-  "(" -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace
-  "}" -> Just $ adjacentScreen next
-  "{" -> Just $ adjacentScreen prev
-  "^" -> Just firstWorkspaceId
-  "'" -> Just $ do
-           l <- lastLocation
-           case l of
-            Just (Location ws _) -> return ws
-            Nothing -> getCurrentWorkspace
-  "." -> Just getCurrentWorkspace
-  "$" -> Just lastWorkspaceId
-  "/" -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT (
-      (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId)
-  " " -> Just $ accompaningWorkspace <$> getCurrentWorkspace
-  _ -> Nothing