Rename Lang to WindowManagementLanguage (Moved to Wml.hs). Add more features to it.

6 files changed, 264 insertions, 148 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 5a5aecf..c12322a 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -57,13 +57,6 @@ instance XPrompt WinPrompt where
     showXPrompt _ = "[Window] "
     commandToComplete _ = id
 
-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
@@ -88,6 +81,12 @@ gotoWorkspace wid = do
   addHiddenWorkspace wid
   windows $ S.greedyView wid
 
+moveLocationToWorkspace :: Location -> WorkspaceId ->  X ()
+moveLocationToWorkspace (Location _ (Just win)) wid = do
+  addHiddenWorkspace wid
+  windows $ shiftWin wid win
+moveLocationToWorkspace _ _ = return ()
+
 getCurrentWorkspace :: X WorkspaceId
 getCurrentWorkspace = withWindowSet $
   \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do
diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs
index 62ecdd3..d20d001 100644
--- a/src/Rahm/Desktop/DMenu.hs
+++ b/src/Rahm/Desktop/DMenu.hs
@@ -16,7 +16,7 @@ data Colors =
   }  | DefaultColors
 
 menuCommand :: [String]
-menuCommand = ["rofi", "-monitor", "-4", "-dmenu", "-sort", "-levenshtein-sort"]
+menuCommand = ["rofi", "-monitor", "-4", "-i", "-dmenu", "-sort", "-levenshtein-sort"]
 
 menuCommandString :: String
 menuCommandString = unwords menuCommand
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index da3b695..6973b81 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -52,7 +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.Keys.Wml
 import Rahm.Desktop.MouseMotion
 import Rahm.Desktop.PassMenu
 import Rahm.Desktop.PromptConfig
@@ -140,7 +140,7 @@ keymap = runKeys $ do
   let subkeys keysM = Submap (runKeys keysM config)
       repeatable keysM = Repeat (runKeys keysM config)
 
-  bind xK_apostrophe $ do
+  forM_ [xK_apostrophe, xK_w] $ \k -> bind k $ do
     justMod $
       doc "Jumps between marks." $
       runMaybeT_ $ do
@@ -189,8 +189,9 @@ keymap = runKeys $ do
   bind xK_F8 $
 
     justMod $
-      doc "Print this documentation." $
-      sendMessage toggleHole
+      doc "Experimental" $ do
+        (logs . printf "WS: %s" . show . fmap workspaceName) =<< workspaceForString ",^"
+        (logs . printf "Wins: %s" . show) =<< locationSetForString "&s@,^"
 
   bind xK_F10 $ do
     justMod playPauseDoc
@@ -489,9 +490,6 @@ keymap = runKeys $ do
         bind xK_v $
           justMod (return () :: X ())
 
-  bind xK_w $ do
-    justMod $ doc "Jump to a window (via rofi)" windowJump
-
   bind xK_x $ do
     justMod $
       doc "Toggles respect for struts." $
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
new file mode 100644
index 0000000..47be2e7
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -0,0 +1,252 @@
+-- Wml: Window Management Language.
+--
+-- Parser for WML objects
+--
+-- Some examples of WML objects are:
+--
+-- a          // The workspace or window (context dependent) tagged 'a'
+-- @a         // All windows on workspace 'a' or the workspace with window 'a'
+-- ,.         // The workspace to to the right of the current one.
+-- @,.        // All windows on the workspace to the right of the current one.
+-- @,^        // All the windows on the screen second from the left
+-- &z!~@,,^   // The window tagged with z and The last window on the screen third from the left
+-- @@s        // All the windows that share a workspace with the window tagged s
+-- \%@s       // All windows except those on workspace 's'
+module Rahm.Desktop.Keys.Wml where
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State as S
+import Control.Monad.Trans.Class
+import Control.Monad (join, forM_)
+
+import Data.Char (isAlphaNum, isAlpha, isDigit, ord)
+import Data.Maybe (fromMaybe)
+import XMonad.Actions.CopyWindow as CopyWindow
+import XMonad.Util.Run (safeSpawn)
+import Prelude hiding (head, last)
+import Data.List.Safe (head, last)
+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 = "@"
+  }
+
+floatWorkspace :: Workspace -> Workspace
+floatWorkspace ws =
+  Workspace {
+    moveLocationToWorkspaceFn = \location -> do
+      forM_ (locationWindow location) $ \win -> do
+        logs $ "Float " ++ show win
+        windows $ W.float win (W.RationalRect 0 0 100 100)
+        withWindowSet $ logs . show . W.floating
+      moveLocationToWorkspaceFn ws location
+  , gotoWorkspaceFn = gotoWorkspaceFn ws
+  , workspaceName = workspaceName ws
+  }
+
+joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a
+joinMaybe (MaybeT ma) = MaybeT $ join <$> ma
+
+class (Monad m) => KeyFeeder m where
+  fromX :: X a -> m a
+
+  fromMaybeTX :: MaybeT X a -> MaybeT m a
+  fromMaybeTX = mapMaybeT fromX
+
+  readNextKey ::
+    (KeyMask -> KeySym -> String -> MaybeT m a) -> MaybeT m a
+
+instance KeyFeeder X where
+  fromX = id
+  readNextKey = mapNextStringWithKeysym
+
+newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT String X a }
+   deriving (Monad, Functor, Applicative)
+
+instance KeyFeeder FeedKeys where
+  fromX = FeedKeys . lift
+
+  readNextKey fn = do
+    ls <- lift $ FeedKeys S.get
+    case ls of
+      (h:t) -> do
+        lift $ FeedKeys $ S.put t
+        fn 0 0 [h]
+      _ -> MaybeT (return Nothing)
+
+feedKeys :: String -> MaybeT FeedKeys a -> X (Maybe a)
+feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf
+
+feedKeysT :: String -> MaybeT FeedKeys a -> MaybeT X a
+feedKeysT s mf = MaybeT $ feedKeys s mf
+
+-- Allows a reference to a workspace in terms of its description in the window
+-- management language.
+workspaceForStringT :: String -> MaybeT X Workspace
+workspaceForStringT str = feedKeysT str readNextWorkspace
+
+-- Like the above, but unwrap the MaybeT
+workspaceForString :: String -> X (Maybe Workspace)
+workspaceForString = runMaybeT . workspaceForStringT
+
+-- Like the above, but unwrap the MaybeT
+locationSetForStringT :: String -> MaybeT X [Location]
+locationSetForStringT s = feedKeysT s readNextLocationSet
+
+locationSetForString :: String -> X [Location]
+locationSetForString s = fromMaybe [] <$> (runMaybeT $ locationSetForStringT s)
+
+-- Returns the next workspaces associated with the next set of keystrokes.
+readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace
+readNextWorkspace =
+  readNextKey $ \mask sym str ->
+    case (mask, sym, str) of
+      (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
+      (_, _, "[") -> mt $ 
+        justWorkspace <$>
+           (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace)
+      (_, _, "]") -> mt $
+        justWorkspace <$>
+          (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace)
+      (_, _, "(") -> mt $ 
+        justWorkspace <$>
+          (adjacentWorkspace prev =<< getCurrentWorkspace)
+      (_, _, ")") -> mt $
+        justWorkspace <$>
+          (adjacentWorkspace next =<< getCurrentWorkspace)
+      (_, _, "}") -> mt $ justWorkspace <$> adjacentScreen next
+      (_, _, "{") -> mt $ justWorkspace <$> adjacentScreen prev
+      (_, _, "^") -> mapMaybeT fromX $ MaybeT $
+        withWindowSet $ \ws -> return $
+          (fmap (justWorkspace . W.tag . W.workspace . snd) . head)
+            (getHorizontallyOrderedScreens ws)
+      (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation
+      (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace
+      (_, _, "$") -> MaybeT $ fromX $
+        withWindowSet $ \ws -> return $
+          (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
+            (getHorizontallyOrderedScreens ws)
+      (_, _, ":") -> floatWorkspace <$> readNextWorkspace
+      (_, _, ",") -> do
+        ws <- readNextWorkspace
+        screens <-
+          mt $
+            map (W.tag . W.workspace . snd)
+              <$> withWindowSet (return . getHorizontallyOrderedScreens)
+
+        let (_, rest) = break (==workspaceName ws) (screens ++ screens)
+
+        justWorkspace <$> (MaybeT $ return $ head $ tail $ rest)
+
+      (_, _, "/") -> fromMaybeTX $ do
+        justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId)
+
+      (_, _, "@") -> do
+        loc <- readNextLocationSet
+        MaybeT (return $ (justWorkspace . locationWorkspace) <$> head loc)
+
+      (_, _, " ") -> mt $
+        justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
+      (_, _, "_") -> return blackHoleWorkspace
+      (_, _, "-") -> return alternateWorkspace
+      _ -> MaybeT (return Nothing)
+  where
+    mt :: (KeyFeeder m) => X a -> MaybeT m a
+    mt = lift . fromX
+
+readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location]
+readNextLocationSet =
+  readNextKey $ \mask sym str ->
+    case (mask, sym, str) of
+      (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch]
+      (_, _, "0") -> (:[]) <$> MaybeT (fromX getMostRecentLocationInHistory)
+      (_, _, [ch]) | isDigit ch ->
+        (:[]) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30))
+      (_, _, ".") -> (:[]) <$> mt getCurrentLocation
+      (_, _, "^") -> (:[]) <$> fromMaybeTX farLeftWindow
+      (_, _, "$") -> (:[]) <$> fromMaybeTX farRightWindow
+      (_, _, "\"") -> (:[]) <$> MaybeT (fromX nextLocation)
+      (_, _, "'") -> (:[]) <$>  MaybeT (fromX lastLocation)
+      (_, _, "*") -> fromMaybeTX $ (:[]) <$> (windowLocation =<< masterWindow)
+      (_, _, "-") -> fromMaybeTX $
+        mapM windowLocation =<< lift getAlternateWindows
+      (_, _, "/") -> fromMaybeTX $
+        (:[]) <$> (windowLocation =<< MaybeT askWindowId)
+      (_, _, "%") -> fromMaybeTX $
+        mapM windowLocation =<< lift (withWindowSet (return . W.allWindows))
+      (_, _, "@") ->
+        (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace
+      (_, _, "!") -> (:[]) <$> (joinMaybe $ head <$> readNextLocationSet)
+      (_, _, ",") -> tail <$> readNextLocationSet
+      (_, _, "~") -> reverse <$> readNextLocationSet
+      (_, _, "?") -> do
+        l1 <- readNextLocationSet
+        l2 <- readNextLocationSet
+        return $ if null l1 then l2 else l1
+
+      (_, _, "&") -> do
+        l1 <- readNextLocationSet
+        l2 <- readNextLocationSet
+        return (l1 ++ l2)
+      (_, _, "\\") -> do
+        l1 <- readNextLocationSet
+        l2 <- readNextLocationSet
+        return $ filter (not . flip elem l2) l1
+        
+      _ -> MaybeT (return Nothing)
+  where
+    mt :: (KeyFeeder m) => X a -> MaybeT m a
+    mt = lift . fromX
diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs
deleted file mode 100644
index 374500d..0000000
--- a/src/Rahm/Desktop/Lang.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-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 90808cf..1ea9782 100644
--- a/src/Rahm/Desktop/Marking.hs
+++ b/src/Rahm/Desktop/Marking.hs
@@ -1,7 +1,6 @@
 module Rahm.Desktop.Marking (
   markCurrentWindow,
   jumpToMark,
-  moveLocationToWorkspace,
   setAlternateWindows,
   getAlternateWindows,
   setAlternateWorkspace,
@@ -131,11 +130,6 @@ swapWithFocused winToSwap stackSet =
           mapWindows (
             \w -> if w == winToSwap then focused else w) stackSet
 
-moveLocationToWorkspace :: Location -> WorkspaceId ->  X ()
-moveLocationToWorkspace (Location _ (Just win)) wid =
-  windows $ shiftWin wid win
-moveLocationToWorkspace _ _ = return ()
-
 windowRect :: Window -> X (Maybe Rectangle)
 windowRect win = withDisplay $ \dpy -> (do
   (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win