aboutsummaryrefslogtreecommitdiff
path: root/src/Internal
diff options
context:
space:
mode:
Diffstat (limited to 'src/Internal')
-rw-r--r--src/Internal/Keys.hs150
-rw-r--r--src/Internal/Lib.hs137
-rw-r--r--src/Internal/XPlus.hs53
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
generated by cgit (git 2.34.1) at 2026-02-23 07:20:43 +0000