Add ability to fuzzy find and jump to a window based on a prompt

5 files changed, 76 insertions, 8 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 5313c12..fe13cc7 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,5 +1,9 @@
 module Internal.Keys where
 
+import Text.Printf
+import Internal.PromptConfig
+import Data.List
+import System.IO
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Internal.Marking
@@ -9,6 +13,10 @@ import XMonad
 import Control.Monad
 import XMonad.Actions.WindowNavigation
 import qualified XMonad.StackSet as W
+import XMonad.Prompt.Input
+import XMonad.Prompt.Shell
+import XMonad.Prompt
+import Data.Char
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 
@@ -18,6 +26,12 @@ applyKeys config@(XConfig {modMask = modm}) = do
    withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $
      config { keys = ks }
 
+data WinPrompt = WinPrompt
+
+instance XPrompt WinPrompt where
+    showXPrompt _ = "[Window] "
+    commandToComplete _ = id
+
 newKeys :: IO (KeyMap l)
 newKeys =
   withNewMarkContext $ \markContext ->
@@ -33,6 +47,39 @@ newKeys =
           shiftToWorkspace ch = do
             windows $ W.shift $ return ch
 
+          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
+
+          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
@@ -47,6 +94,7 @@ 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_apostrophe), (submap $
               Map.insert
                 (modm, xK_apostrophe)
diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index 4cfe3d3..08aaa7a 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -40,7 +40,7 @@ instance (Show a) => LayoutClass Center a where
         nWin = length (W.integrate stack)
         winsTop = nWin `div` 8
 
-        portion = fromIntegral $ nWin `div` 6
+        portion = fromIntegral $ (guard 1 (nWin `div` 6))
         winRem = fromIntegral $ nWin `mod` 6
       in do
       let ret =
@@ -50,9 +50,11 @@ instance (Show a) => LayoutClass Center a where
                  ++ (divRect rightRect portion)
                  ++ (divRect bottomRect (portion * 2))
                  ++ (divRect leftRect (portion + winRem))), Just l)
-      liftIO $ writeFile "/tmp/wtf.txt" (description l ++ ": " ++ show (fst ret))
       return ret
    where
+    guard n 0 = n
+    guard _ n = n
+
     divRect (Rectangle x y w h) n =
       if h > w
         then
diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs
index 5f0572d..4a980b4 100644
--- a/src/Internal/LayoutDraw.hs
+++ b/src/Internal/LayoutDraw.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
-ScopedTypeVariables #-}
+ScopedTypeVariables, BangPatterns #-}
 module Internal.LayoutDraw where
 
 import System.Process
@@ -27,13 +27,18 @@ showLayout = do
     xpm <- drawPng layout
     return $ Just $ printf "<icon=%s/>" xpm
 
+iconSize :: (Num a) => (a, a)
+iconSize = (64, 32)
+
 drawPng :: (LayoutClass layout Window) => layout Window -> X String
 drawPng l = do
     dir <- getXMonadDir
     let sixWindows = [1..(4 :: Window)]
     let stack = differentiate sixWindows
     (rects, _) <-
-          runLayout (Workspace "0" l stack) (Rectangle 0 0 (64 * 30) (32 * 30))
+          runLayout
+            (Workspace "0" l stack)
+            (Rectangle 0 0 (fst iconSize * 30) (snd iconSize * 30))
     return ()
 
     let descr = description l
@@ -80,7 +85,7 @@ drawPng l = do
 
             surfaceWriteToPNG surface filepathPng
 
-            _ <- readProcessWithExitCode
+            (!_) <- readProcessWithExitCode
               "/usr/bin/convert"
               [filepathPng, filepathXpm]
               ""
@@ -88,8 +93,9 @@ drawPng l = do
 
     return filepathXpm
     where
-      padR (Rectangle x y w h) =
-        Rectangle x y (max 1 $ w - 120) (max 1 $ h - 120)
+      padR = id
+      -- padR (Rectangle x y w h) =
+      --   Rectangle x y (max 1 $ w - 120) (max 1 $ h - 120)
 
 newtype InterceptLayout l a =
     InterceptLayout {
diff --git a/src/Internal/PromptConfig.hs b/src/Internal/PromptConfig.hs
new file mode 100644
index 0000000..0db3027
--- /dev/null
+++ b/src/Internal/PromptConfig.hs
@@ -0,0 +1,12 @@
+module Internal.PromptConfig where
+
+import XMonad.Prompt
+
+xpConfig :: XPConfig
+xpConfig = def {
+               font = "xft:Source Code Pro:size=10"
+             , bgColor = "#404040"
+             , fgColor = "#8888ff"
+             , promptBorderWidth = 0
+             , height = 40
+             }
diff --git a/src/Main.hs b/src/Main.hs
index 11d9eab..e3c1cc1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,7 +25,7 @@ main = do
 
   config <-
     applyKeys $ def
-       { terminal    = "st"
+       { terminal    = "sakura"
        , modMask     = mod4Mask
        , borderWidth = 0
        , keys = \config -> mempty