From 04d0ab42a39df36acfc84846cc122f0bb9786446 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 12 Nov 2021 11:06:37 -0700 Subject: Use XMonad's EtensibleState Change the Marking to use XMonad's extensible state rather than hand-rolling it myself. Allowed me to delete the XPlus monad. --- src/Internal/Keys.hs | 55 ++++++++++++++++------------------ src/Internal/Lib.hs | 67 ++++++++++++++--------------------------- src/Internal/Marking.hs | 80 +++++++++++++++++-------------------------------- src/Internal/XPlus.hs | 53 -------------------------------- 4 files changed, 75 insertions(+), 180 deletions(-) delete mode 100644 src/Internal/XPlus.hs (limited to 'src') diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 64a7506..591861f 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -7,7 +7,6 @@ import Graphics.X11.ExtraTypes.XorgDefault import System.Process import XMonad.Util.Ungrab import XMonad.Layout.Spacing -import Internal.XPlus import Data.Maybe (isJust) import Debug.Trace import Control.Applicative @@ -40,14 +39,13 @@ import Internal.PassMenu type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) applyKeys :: XConfig l -> IO (XConfig l) -applyKeys config@(XConfig {modMask = modm}) = - withNewMarkContext $ \markContext -> do - ks <- newKeys markContext - ms <- newMouse markContext +applyKeys config@(XConfig {modMask = modm}) = do + ks <- newKeys + ms <- newMouse return $ config { keys = ks, mouseBindings = ms } -newMouse :: MarkContext -> IO (XConfig l -> Map (KeyMask, Button) (Window -> X ())) -newMouse markContext = +newMouse :: IO (XConfig l -> Map (KeyMask, Button) (Window -> X ())) +newMouse = return $ \config@(XConfig {modMask = modm}) -> Map.fromList [ ((modm, button1), \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster) @@ -71,8 +69,8 @@ modifyWindowBorder :: Integer -> SpacingModifier modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> (Border (a + i) (b + i) (c + i) (d + i)) -newKeys :: MarkContext -> IO (KeyMap l) -newKeys markContext = +newKeys :: IO (KeyMap l) +newKeys = return $ \config@(XConfig {modMask = modm}) -> Map.fromList [ ((modm, xK_F12), (void $ spawn "spotify-control next")) @@ -100,33 +98,30 @@ newKeys markContext = , ((mod4Mask, xK_BackSpace), (void $ spawn "xterm")) , ((modm, xK_BackSpace), (void $ spawn "pkill -SIGUSR1 xmobar")) , ((modm, xK_t), (void $ spawn (terminal config))) - , ((modm, xK_m), (submap $ mapAlpha modm (markCurrentWindow markContext))) - , ((modm, xK_w), runXPlus markContext config windowJump) + , ((modm, xK_m), (submap $ mapAlpha modm markCurrentWindow)) + , ((modm, xK_w), windowJump) , ((modm, xK_space), sendMessage NextLayout) , ((modm .|. shiftMask, xK_space), sendMessage FirstLayout) , ((modm, xK_apostrophe), (submap $ Map.insert (modm, xK_apostrophe) - (jumpToLast markContext) - (mapAlpha modm (jumpToMark markContext)))) + jumpToLast + (mapAlpha modm jumpToMark))) , ((modm .|. shiftMask, xK_apostrophe), (submap $ Map.insert (modm .|. shiftMask, xK_apostrophe) - (swapWithLastMark markContext) - (mapAlpha (modm .|. shiftMask) (swapWithMark markContext)))) + swapWithLastMark + (mapAlpha (modm .|. shiftMask) swapWithMark))) , ((modm, xK_g), (submap $ - mapNumbersAndAlpha 0 ( - runXPlus markContext config . gotoWorkspace))) + mapNumbersAndAlpha 0 gotoWorkspace)) , ((modm .|. shiftMask, xK_g), (submap $ - mapNumbersAndAlpha 0 ( - runXPlus markContext config . shiftToWorkspace))) + mapNumbersAndAlpha 0 shiftToWorkspace)) , ((modm .|. shiftMask .|. mod1Mask, xK_g), (submap $ - mapNumbersAndAlpha 0 ( - runXPlus markContext config . swapWorkspace))) + mapNumbersAndAlpha 0 swapWorkspace)) , ((modm, xK_minus), sendMessage (IncMasterN (-1))) , ((modm, xK_plus), sendMessage (IncMasterN 1)) @@ -149,17 +144,17 @@ newKeys markContext = , ((modm, xK_Tab), windows W.focusDown) , ((modm .|. shiftMask, xK_Tab), windows W.focusUp) - , ((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, xK_a), withScreen W.view 0) + , ((modm, xK_o), withScreen W.view 1) + , ((modm, xK_e), 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) - , ((modm .|. mod1Mask, xK_a), runXPlus markContext config (withScreen W.greedyView 0)) - , ((modm .|. mod1Mask, xK_o), runXPlus markContext config (withScreen W.greedyView 1)) - , ((modm .|. mod1Mask, xK_e), runXPlus markContext config (withScreen W.greedyView 2)) + , ((modm .|. mod1Mask, xK_a), withScreen W.greedyView 0) + , ((modm .|. mod1Mask, xK_o), withScreen W.greedyView 1) + , ((modm .|. mod1Mask, xK_e), withScreen W.greedyView 2) , ((modm, xK_b), sendMessage ToggleStruts) -- Buttons programmed on my mouse. diff --git a/src/Internal/Lib.hs b/src/Internal/Lib.hs index 08ba2b7..1a1d602 100644 --- a/src/Internal/Lib.hs +++ b/src/Internal/Lib.hs @@ -15,7 +15,6 @@ 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) @@ -65,18 +64,16 @@ getHorizontallyOrderedScreens windowSet = screens = current windowSet : visible windowSet -gotoWorkspace :: WorkspaceName -> XPlus l () +gotoWorkspace :: WorkspaceName -> X () gotoWorkspace ch = do - mc <- getMarkContext - liftXPlus $ do - saveLastMark mc - windows $ greedyView $ return ch + saveLastMark + windows $ greedyView $ return ch -shiftToWorkspace :: WorkspaceName -> XPlus l () -shiftToWorkspace = liftXPlus . windows . shift . return +shiftToWorkspace :: WorkspaceName -> X () +shiftToWorkspace = windows . shift . return -swapWorkspace :: WorkspaceName -> XPlus l () -swapWorkspace toWorkspaceName = liftXPlus $ do +swapWorkspace :: WorkspaceName -> X () +swapWorkspace toWorkspaceName = do windows $ \ss -> do let fromWorkspace = tag $ workspace $ current ss toWorkspace = [toWorkspaceName] in @@ -128,40 +125,22 @@ prev :: Selector prev = Selector $ \a l -> let (Selector fn) = next in fn a (reverse l) -withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> XPlus l () +withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () withScreen fn n = do - markContext <- getMarkContext + windows $ \windowSet -> + case (getHorizontallyOrderedScreens windowSet !! n) of + Nothing -> windowSet + Just screen -> fn (tag $ workspace screen) windowSet - liftXPlus $ - windows $ \windowSet -> - case (getHorizontallyOrderedScreens windowSet !! n) of - Nothing -> windowSet - Just screen -> fn (tag $ workspace screen) windowSet - -windowJump :: XPlus l () +windowJump :: X () windowJump = do - markContext <- getMarkContext - - liftXPlus $ do - windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) - - windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId - - case windowId of - Nothing -> return () - Just wid -> do - saveLastMark markContext - focus wid - -- 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 () + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + + windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId + + case windowId of + Nothing -> return () + Just wid -> do + saveLastMark + focus wid diff --git a/src/Internal/Marking.hs b/src/Internal/Marking.hs index f9083d2..229ea02 100644 --- a/src/Internal/Marking.hs +++ b/src/Internal/Marking.hs @@ -11,6 +11,8 @@ import System.IO import Control.Exception import System.Environment +import qualified XMonad.Util.ExtensibleState as XS + import qualified Data.Map as Map {- Submodule that handles marking windows so they can be jumped back to. -} @@ -23,65 +25,38 @@ data MarkState = , markLast :: Maybe Window } deriving (Read, Show) -data MarkContext = MarkContext (IORef MarkState) - -readMarkState :: IO MarkState -readMarkState = do - -- TODO(rahm) The mark state should use the extensible state constructs in the - -- XState rather than relying on IO. - dir <- getEnv "HOME" - let markstate = dir ".xmonad" "markstate" - catch - (read <$> (hGetContents =<< openFile markstate ReadMode)) - (\(e :: IOError) -> return (MarkState mempty Nothing)) - -saveMarkState :: MarkState -> X () -saveMarkState ms = do - dir <- io $ getEnv "HOME" - let markstate = dir ".xmonad" "markstate" - liftIO $ writeFile markstate (show ms) - -withNewMarkContext :: (MarkContext -> IO a) -> IO a -withNewMarkContext fn = do - ioref <- newIORef =<< readMarkState - fn (MarkContext ioref) +instance ExtensionClass MarkState where + initialValue = MarkState Map.empty Nothing -markCurrentWindow :: MarkContext -> Mark -> X () -markCurrentWindow (MarkContext ioref) mark = do +markCurrentWindow :: Mark -> X () +markCurrentWindow mark = do withFocused $ \win -> - liftIO $ - modifyIORef ioref $ \state@(MarkState {markStateMap = ms}) -> + XS.modify $ \state@(MarkState {markStateMap = ms}) -> state { markStateMap = Map.insert mark win ms } - saveMarkState =<< liftIO (readIORef ioref) - -saveLastMark :: MarkContext -> X () -saveLastMark (MarkContext ioref) = - withFocused $ \win -> do - liftIO $ modifyIORef ioref (\state -> state { markLast = Just win }) +saveLastMark :: X () +saveLastMark = + withFocused $ \win -> + XS.modify $ \state -> state { markLast = Just win } -jumpToLast :: MarkContext -> X () -jumpToLast ctx@(MarkContext ioref) = do - m <- markLast <$> (liftIO $ readIORef ioref) - saveLastMark ctx +jumpToLast :: X () +jumpToLast = do + m <- markLast <$> XS.get + saveLastMark mapM_ focus m - saveMarkState =<< liftIO (readIORef ioref) - -jumpToMark :: MarkContext -> Mark -> X () -jumpToMark ctx@(MarkContext ioref) mark = do - MarkState {markStateMap = m} <- liftIO $ readIORef ioref +jumpToMark :: Mark -> X () +jumpToMark mark = do + MarkState {markStateMap = m} <- XS.get case Map.lookup mark m of Nothing -> return () Just w -> do - saveLastMark ctx + saveLastMark focus w - saveMarkState =<< liftIO (readIORef ioref) - mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd mapWindows fn (StackSet cur vis hid float) = StackSet @@ -117,20 +92,19 @@ swapWithFocused winToSwap stackSet = mapWindows ( \w -> if w == winToSwap then focused else w) stackSet -swapWithLastMark :: MarkContext -> X () -swapWithLastMark ctx@(MarkContext ioref) = do - MarkState {markStateMap = m} <- liftIO $ readIORef ioref - m <- markLast <$> (liftIO $ readIORef ioref) - saveLastMark ctx +swapWithLastMark :: X () +swapWithLastMark = do + m <- markLast <$> XS.get + saveLastMark case m of Nothing -> return () Just win -> windows $ swapWithFocused win -swapWithMark :: MarkContext -> Mark -> X () -swapWithMark ctx@(MarkContext ioref) mark = do - MarkState {markStateMap = m} <- liftIO $ readIORef ioref - saveLastMark ctx +swapWithMark :: Mark -> X () +swapWithMark mark = do + MarkState {markStateMap = m} <- XS.get + saveLastMark case Map.lookup mark m of Nothing -> return () diff --git a/src/Internal/XPlus.hs b/src/Internal/XPlus.hs deleted file mode 100644 index c546665..0000000 --- a/src/Internal/XPlus.hs +++ /dev/null @@ -1,53 +0,0 @@ -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 -- cgit