diff options
| -rw-r--r-- | Accordion.hs | 9 | ||||
| -rw-r--r-- | Circle.hs | 6 | ||||
| -rw-r--r-- | Combo.hs | 30 | ||||
| -rw-r--r-- | Decoration.hs | 20 | ||||
| -rw-r--r-- | HintedTile.hs | 3 | ||||
| -rw-r--r-- | LayoutHelpers.hs | 25 | ||||
| -rw-r--r-- | LayoutHints.hs | 11 | ||||
| -rw-r--r-- | LayoutScreens.hs | 2 | ||||
| -rw-r--r-- | Magnifier.hs | 23 | ||||
| -rw-r--r-- | Mosaic.hs | 11 | ||||
| -rw-r--r-- | SimpleStacking.hs | 24 | ||||
| -rw-r--r-- | Tabbed.hs | 49 | ||||
| -rw-r--r-- | TwoPane.hs | 2 |
13 files changed, 97 insertions, 118 deletions
diff --git a/Accordion.hs b/Accordion.hs index 96ba448..37dc972 100644 --- a/Accordion.hs +++ b/Accordion.hs @@ -31,10 +31,11 @@ import XMonadContrib.LayoutHelpers ( idModify ) accordion :: Eq a => Layout a accordion = Layout { doLayout = accordionLayout, modifyLayout = idModify } -accordionLayout :: Eq a => Rectangle -> W.Stack a -> X [(a, Rectangle)] -accordionLayout sc ws = return $ (zip ups tops) ++ - [(W.focus ws, mainPane)] ++ - (zip dns bottoms) +accordionLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Layout a)) +accordionLayout sc ws = return ((zip ups tops) ++ + [(W.focus ws, mainPane)] ++ + (zip dns bottoms) + ,Nothing) where ups = W.up ws dns = W.down ws (top, allButTop) = splitVerticallyBy (1%8) sc @@ -22,14 +22,16 @@ import Graphics.X11.Xlib import XMonad import StackSet (integrate, Stack(..)) +import XMonadContrib.LayoutHelpers ( idModify ) + -- $usage -- You can use this module with the following in your Config.hs file: -- -- > import XMonadContrib.Circle circle :: Layout a -circle = Layout { doLayout = \r s -> return . raise (length (up s)) . circleLayout r $ integrate s, - modifyLayout = return . const Nothing } +circle = Layout { doLayout = \r s -> return (raise (length (up s)) . circleLayout r $ integrate s, Nothing), + modifyLayout = idModify } circleLayout :: Rectangle -> [a] -> [(a, Rectangle)] circleLayout _ [] = [] @@ -18,9 +18,9 @@ module XMonadContrib.Combo ( combo ) where +import Data.Maybe ( isJust ) import XMonad import StackSet ( integrate, differentiate ) -import Operations ( UnDoLayout(UnDoLayout) ) -- $usage -- @@ -37,10 +37,11 @@ import Operations ( UnDoLayout(UnDoLayout) ) combo :: [(Layout a, Int)] -> Layout a -> Layout a combo origls super = Layout { doLayout = \r s -> arrange r (integrate s), modifyLayout = message } - where arrange _ [] = return [] - arrange r [w] = return [(w,r)] + where arrange _ [] = return ([], Nothing) + arrange r [w] = return ([(w,r)], Nothing) arrange rinput origws = - do rs <- map snd `fmap` runLayout super rinput (differentiate $ take (length origls) origws) + do rs <- (map snd . fst) `fmap` + runLayout super rinput (differentiate $ take (length origls) origws) let wss [] _ = [] wss [_] ws = [ws] wss (n:ns) ws = take len1 ws : wss ns (drop len1 ws) @@ -48,13 +49,16 @@ combo origls super = Layout { doLayout = \r s -> arrange r (integrate s), modify out <- sequence $ zipWith3 runLayout (map fst origls) rs (map differentiate $ wss (take (length rs) $ map snd origls) origws) - return $ concat out - message m = case fromMessage m of - Just UnDoLayout -> fmap (\(super':ls') -> Just $ combo (zip ls' $ map snd origls) super') - (broadcastPrivate UnDoLayout (super:map fst origls)) - _ -> fmap (maybe Nothing (Just . combo origls)) (modifyLayout super m) + let origls' = zipWith foo (out++repeat ([],Nothing)) origls + foo (_, Nothing) x = x + foo (_, Just l') (_, n) = (l', n) + return (concat $ map fst out, Just $ combo origls' super) + message m = do mls <- broadcastPrivate m (super:map fst origls) + return $ (\(super':ls') -> combo (zip ls' $ map snd origls) super') `fmap` mls -broadcastPrivate :: Message a => a -> [Layout b] -> X [Layout b] -broadcastPrivate a ol = mapM f ol - where f l = do ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l) - return $ maybe l id ml' +broadcastPrivate :: SomeMessage -> [Layout b] -> X (Maybe [Layout b]) +broadcastPrivate a ol = do nml <- mapM f ol + if any isJust nml + then return $ Just $ zipWith ((flip maybe) id) ol nml + else return Nothing + where f l = modifyLayout l a `catchX` return Nothing diff --git a/Decoration.hs b/Decoration.hs index 6b63475..2543af9 100644 --- a/Decoration.hs +++ b/Decoration.hs @@ -24,7 +24,7 @@ import Control.Monad.Reader ( asks ) import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras ( Event(AnyEvent,ButtonEvent), ev_subwindow, ev_event_type, ev_window ) -import XMonadContrib.LayoutHooks +import XMonadContrib.LayoutHelpers ( ModLay, layoutModify, idModDo ) import XMonad import Operations ( UnDoLayout(UnDoLayout) ) @@ -33,19 +33,19 @@ import Operations ( UnDoLayout(UnDoLayout) ) -- You can use this module for writing other extensions. -- See, for instance, "XMonadContrib.Tabbed" -newDecoration :: Window -> Rectangle -> Int -> Pixel -> Pixel -> String - -> (Display -> Window -> GC -> FontStruct -> X ()) -> X () -> X Window -newDecoration decfor (Rectangle x y w h) th fg bg fn draw click = do +newDecoration :: Window -> Rectangle -> Int -> Pixel -> Pixel + -> (Display -> Window -> GC -> X ()) -> X () -> X Window +newDecoration decfor (Rectangle x y w h) th fg bg draw click = do d <- asks display rt <- asks theRoot win <- io $ createSimpleWindow d rt x y w h (fromIntegral th) fg bg io $ selectInput d win $ exposureMask .|. buttonPressMask io $ mapWindow d win - let hook :: SomeMessage -> X Bool - hook sm | Just e <- fromMessage sm = handle_event e >> return True - | Just UnDoLayout == fromMessage sm = io (destroyWindow d win) >> return False - | otherwise = return True + let hook :: SomeMessage -> X (Maybe (ModLay a)) + hook sm | Just e <- fromMessage sm = handle_event e >> return Nothing + | Just UnDoLayout == fromMessage sm = io (destroyWindow d win) >> return (Just id) + | otherwise = return Nothing handle_event (ButtonEvent {ev_subwindow = thisw,ev_event_type = t}) | t == buttonPress && thisw == win = click @@ -56,9 +56,7 @@ newDecoration decfor (Rectangle x y w h) th fg bg fn draw click = do | thisw == decfor && t == propertyNotify = withGC win fn draw handle_event _ = return () - addLayoutMessageHook hook - - return win + return $ layoutModify idModDo hook l -- FIXME: withGC should use bracket (but can't, unless draw is an IO thing) withGC :: Drawable -> String -> (Display -> Drawable -> GC -> FontStruct -> X ()) -> X () diff --git a/HintedTile.hs b/HintedTile.hs index 3df8014..ef0bb96 100644 --- a/HintedTile.hs +++ b/HintedTile.hs @@ -44,7 +44,8 @@ tall = tile splitHorizontally divideVertically tile split divide nmaster delta frac = Layout { doLayout = \r w' -> let w = W.integrate w' in do { hints <- sequence (map getHints w) - ; return $ zip w (tiler frac r `uncurry` splitAt nmaster hints) } + ; return (zip w (tiler frac r `uncurry` splitAt nmaster hints) + , Nothing) } , modifyLayout = \m -> return $ fmap resize (fromMessage m) `mplus` fmap incmastern (fromMessage m) } diff --git a/LayoutHelpers.hs b/LayoutHelpers.hs index 86cd295..ee7a7c5 100644 --- a/LayoutHelpers.hs +++ b/LayoutHelpers.hs @@ -17,7 +17,7 @@ module XMonadContrib.LayoutHelpers ( DoLayout, ModDo, ModMod, ModLay, layoutModify, l2lModDo, idModify, - idModMod, + idModDo, idModMod, ) where import Graphics.X11.Xlib ( Rectangle ) @@ -27,8 +27,7 @@ import StackSet ( Stack, integrate ) -- $usage -- Use LayoutHelpers to help write easy Layouts. ---type DoLayout a = Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a)) -type DoLayout a = Rectangle -> Stack a -> X [(a, Rectangle)] +type DoLayout a = Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a)) type ModifyLayout a = SomeMessage -> X (Maybe (Layout a)) type ModDo a = Rectangle -> Stack a -> [(a, Rectangle)] -> X ([(a, Rectangle)], Maybe (ModLay a)) @@ -38,16 +37,12 @@ type ModLay a = Layout a -> Layout a layoutModify :: ModDo a -> ModMod a -> ModLay a layoutModify fdo fmod l = Layout { doLayout = dl, modifyLayout = modl } - where dl r s = do --(ws, ml') <- doLayout l r s - ws <- doLayout l r s + where dl r s = do (ws, ml') <- doLayout l r s (ws', mmod') <- fdo r s ws - --let ml'' = case mmod' of - -- Just mod' -> Just $ mod' $ maybe l id ml' - -- Nothing -> layoutModify fdo mod `fmap` ml' - --return (ws', ml'') - case mmod' of - Just _ -> fail "Sorry, can't yet safely modify layouts in doLayout." - Nothing -> return ws' + let ml'' = case mmod' of + Just mod' -> Just $ mod' $ maybe l id ml' + Nothing -> layoutModify fdo fmod `fmap` ml' + return (ws', ml'') modl m = do ml' <- modifyLayout l m mmod' <- fmod m return $ case mmod' of @@ -55,8 +50,10 @@ layoutModify fdo fmod l = Layout { doLayout = dl, modifyLayout = modl } Nothing -> layoutModify fdo fmod `fmap` ml' l2lModDo :: (Rectangle -> [a] -> [(a,Rectangle)]) -> DoLayout a ---l2lModDo dl r s = return (dl r $ integrate s, Nothing) -l2lModDo dl r s = return (dl r $ integrate s) +l2lModDo dl r s = return (dl r $ integrate s, Nothing) + +idModDo :: ModDo a +idModDo _ _ wrs = return (wrs, Nothing) idModify :: ModifyLayout a idModify _ = return Nothing diff --git a/LayoutHints.hs b/LayoutHints.hs index 274c037..5daece8 100644 --- a/LayoutHints.hs +++ b/LayoutHints.hs @@ -21,6 +21,7 @@ import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras ( getWMNormalHints ) import {-#SOURCE#-} Config (borderWidth) import XMonad hiding ( trace ) +import XMonadContrib.LayoutHelpers ( layoutModify, idModMod ) -- $usage -- > import XMonadContrib.LayoutHints @@ -32,12 +33,10 @@ adjBorders :: Dimension -> D -> D adjBorders mult (w,h) = (w+2*mult*borderWidth, h+2*mult*borderWidth) layoutHints :: Layout Window -> Layout Window -layoutHints l = l { doLayout = \r x -> doLayout l r x >>= applyHints - , modifyLayout = \x -> fmap layoutHints `fmap` modifyLayout l x } - -applyHints :: [(Window, Rectangle)] -> X [(Window, Rectangle)] -applyHints xs = mapM applyHint xs - where applyHint (w,Rectangle a b c d) = +layoutHints = layoutModify applyHints idModMod + where applyHints _ _ xs = do xs' <- mapM applyHint xs + return (xs', Nothing) + applyHint (w,Rectangle a b c d) = withDisplay $ \disp -> do sh <- io $ getWMNormalHints disp w let (c',d') = adjBorders 1 . applySizeHints sh . adjBorders (-1) $ (c,d) diff --git a/LayoutScreens.hs b/LayoutScreens.hs index 7037ebe..bda3034 100644 --- a/LayoutScreens.hs +++ b/LayoutScreens.hs @@ -48,7 +48,7 @@ layoutScreens :: Int -> Layout Int -> X () layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens." layoutScreens nscr l = do rtrect <- asks theRoot >>= getWindowRectangle - wss <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] } + (wss, _) <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] } modify $ \s -> s { xineScreens = map snd wss , statusGaps = take nscr $ (statusGaps s) ++ repeat (0,0,0,0) } diff --git a/Magnifier.hs b/Magnifier.hs index e2d0c80..da18c2e 100644 --- a/Magnifier.hs +++ b/Magnifier.hs @@ -24,6 +24,7 @@ module XMonadContrib.Magnifier ( import Graphics.X11.Xlib import XMonad import StackSet +import XMonadContrib.LayoutHelpers -- $usage -- > import XMonadContrib.Magnifier @@ -31,24 +32,20 @@ import StackSet -- | Increase the size of the window that has focus, unless it is the master window. magnifier :: Eq a => Layout a -> Layout a -magnifier l = l { doLayout = \r s -> unlessMaster applyMagnifier r s `fmap` doLayout l r s - , modifyLayout = \x -> fmap magnifier `fmap` modifyLayout l x } +magnifier = layoutModify (unlessMaster applyMagnifier) idModMod -- | Increase the size of the window that has focus, even if it is the master window. magnifier' :: Eq a => Layout a -> Layout a -magnifier' l = l { doLayout = \r s -> applyMagnifier r s `fmap` doLayout l r s - , modifyLayout = \x -> fmap magnifier' `fmap` modifyLayout l x } +magnifier' = layoutModify applyMagnifier idModMod +unlessMaster :: ModDo a -> ModDo a +unlessMaster mainmod r s wrs = if null (up s) then return (wrs, Nothing) + else mainmod r s wrs -type DoLayout = Eq a => Rectangle -> Stack a -> [(a, Rectangle)] -> [(a, Rectangle)] - -unlessMaster :: DoLayout -> DoLayout -unlessMaster f r s = if null (up s) then id else f r s - -applyMagnifier :: DoLayout -applyMagnifier r s = reverse . foldr accumulate [] - where accumulate (w,wr) ws | w == focus s = ws ++ [(w, shrink r $ magnify wr)] - | otherwise = (w,wr) : ws +applyMagnifier :: Eq a => ModDo a +applyMagnifier r s wrs = return (map mag wrs, Nothing) + where mag (w,wr) | w == focus s = (w, shrink r $ magnify wr) + | otherwise = (w,wr) magnify :: Rectangle -> Rectangle magnify (Rectangle x y w h) = Rectangle x' y' w' h' @@ -87,7 +87,8 @@ flexibility :: Double flexibility = 0.1 mosaic :: Double -> Double -> M.Map NamedWindow [WindowHint] -> Layout Window -mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate, modifyLayout = return . mlayout } +mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate + , modifyLayout = return . mlayout } where mlayout x = (m1 `fmap` fromMessage x) `mplus` (m2 `fmap` fromMessage x) m1 Shrink = mosaic delta (tileFrac/(1+delta)) hints m1 Expand = mosaic delta (tileFrac*(1+delta)) hints @@ -136,8 +137,8 @@ alterlist f k = M.alter f' k xs' -> Just xs' mosaicL :: Double -> M.Map NamedWindow [WindowHint] - -> Rectangle -> [Window] -> X [(Window, Rectangle)] -mosaicL _ _ _ [] = return [] + -> Rectangle -> [Window] -> X ([(Window, Rectangle)],Maybe (Layout Window)) +mosaicL _ _ _ [] = return ([], Nothing) mosaicL f hints origRect origws = do namedws <- mapM getName origws let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) namedws @@ -152,13 +153,13 @@ mosaicL f hints origRect origws -- myh2 = maxL $ runCountDown largeNumber $ -- sequence $ replicate mediumNumber $ -- mosaic_splits one_split origRect Horizontal sortedws - return $ map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw, + return (map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw, -- show $ rate f meanarea (findlist nw hints) r, -- show r, -- show $ area r/meanarea, -- show $ findlist nw hints]) $ unName nw,crop' (findlist nw hints) r)) $ - flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2] + flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2], Nothing) where mosaic_splits _ _ _ [] = return $ Rated 0 $ M [] mosaic_splits _ r _ [w] = return $ Rated (rate f meanarea (findlist w hints) r) $ OM (w,r) mosaic_splits spl r d ws = maxL `fmap` mapCD (spl r d) (init $ allsplits ws) diff --git a/SimpleStacking.hs b/SimpleStacking.hs index 3229a8b..c66fa9a 100644 --- a/SimpleStacking.hs +++ b/SimpleStacking.hs @@ -21,15 +21,16 @@ module XMonadContrib.SimpleStacking ( simpleStacking ) where -import Control.Monad.State ( modify ) +import Control.Monad.State ( get ) import qualified Data.Map as M import Data.Maybe ( catMaybes ) -import Data.List ( nub, lookup ) -import StackSet ( focus, tag, workspace, current, integrate ) +import Data.List ( nub, lookup, delete ) +import StackSet ( focus, tag, workspace, current, up, down ) import Graphics.X11.Xlib ( Window ) import XMonad +import XMonadContrib.LayoutHelpers -- $usage -- You can use this module for @@ -39,14 +40,9 @@ simpleStacking :: Layout Window -> Layout Window simpleStacking = simpleStacking' [] simpleStacking' :: [Window] -> Layout Window -> Layout Window -simpleStacking' st l = l { doLayout = dl - , modifyLayout = \m -> fmap (simpleStacking' st) `fmap` modifyLayout l m } - where dl r s = do modify $ \ state -> - state { layouts = M.adjust - (\(_,ss)->(simpleStacking' - (focus s:filter (`elem` integrate s) st) l,ss)) - (tag.workspace.current.windowset $ state) - (layouts state) } - lo <- doLayout l r s - let m = map (\ (w,rr) -> (w,(w,rr))) lo - return $ catMaybes $ map ((flip lookup) m) $ nub (focus s : st ++ map fst lo) +simpleStacking' st = layoutModify dl idModMod + where dl r s wrs = let m = map (\ (w,rr) -> (w,(w,rr))) wrs + wrs' = catMaybes $ map ((flip lookup) m) $ + nub (focus s : st ++ map fst wrs) + st' = focus s:filter (`elem` (up s++down s)) st + in return (wrs', Just (simpleStacking' st')) @@ -20,7 +20,8 @@ module XMonadContrib.Tabbed ( , TConf (..), defaultTConf ) where -import Control.Monad ( forM ) +import Control.Monad ( forM, liftM ) +import Control.Monad.State ( gets ) import Graphics.X11.Xlib import XMonad @@ -29,6 +30,7 @@ import Operations ( focus, initColor ) import qualified StackSet as W import XMonadContrib.NamedWindows +import XMonadContrib.LayoutHelpers ( idModify ) -- $usage -- You can use this module with the following in your configuration file: @@ -50,42 +52,23 @@ import XMonadContrib.NamedWindows -- > defaultLayouts = [ simpleStacking $ tabbed shrinkText myconfig -- > , ... ] -data TConf = - TConf { activeColor :: String - , inactiveColor :: String - , bgColor :: String - , textColor :: String - , fontName :: String - , tabSize :: Int - } deriving (Show, Read) - -defaultTConf :: TConf -defaultTConf = - TConf { activeColor ="#BBBBBB" - , inactiveColor = "#888888" - , bgColor = "#000000" - , textColor = "#000000" - , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , tabSize = 20 - } +tabbed :: Shrinker -> Layout Window +tabbed shrinkT = Layout { doLayout = dolay shrinkT, modifyLayout = const (return Nothing) } -tabbed :: Shrinker -> TConf -> Layout Window -tabbed shrinkT config = Layout { doLayout = dolay shrinkT config, modifyLayout = const (return Nothing) } - -dolay :: Shrinker -> TConf -> Rectangle -> W.Stack Window -> X [(Window, Rectangle)] -dolay _ _ sc (W.Stack w [] []) = return [(w,sc)] -dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy -> - do activecolor <- io $ initColor dpy $ activeColor conf - inactivecolor <- io $ initColor dpy $ inactiveColor conf - textcolor <- io $ initColor dpy $ textColor conf - bgcolor <- io $ initColor dpy $ bgColor conf +dolay :: Shrinker -> Rectangle -> W.Stack Window -> X [(Window, Rectangle)] +dolay _ sc (W.Stack w [] []) = return [(w,sc)] +dolay shr sc@(Rectangle x y wid _) s = withDisplay $ \dpy -> + do activecolor <- io $ initColor dpy "#BBBBBB" + inactivecolor <- io $ initColor dpy "#888888" + textcolor <- io $ initColor dpy "#000000" + bgcolor <- io $ initColor dpy "#000000" let ws = W.integrate s ts = gentabs conf x y wid (length ws) tws = zip ts ws - maketab (t,ow) = newDecoration ow t 1 bgcolor activecolor (fontName conf) (drawtab t ow) (focus ow) - drawtab r@(Rectangle _ _ wt ht) ow d w' gc fn = + maketab (t,ow) = newDecoration ow t 1 bgcolor activecolor (drawtab t ow) (focus ow) + drawtab r@(Rectangle _ _ wt ht) ow d w' gc = do nw <- getName ow - let tabcolor = if W.focus s == ow then activecolor else inactivecolor + tabcolor <- (maybe inactivecolor (\focusw -> if focusw == ow then activecolor else inactivecolor) . W.peek) `liftM` gets windowset io $ setForeground d gc tabcolor io $ fillRectangles d w' gc [Rectangle 0 0 wt ht] io $ setForeground d gc textcolor @@ -99,7 +82,7 @@ dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy -> (fromIntegral (wt `div` 2) - fromIntegral (width `div` 2)) ((fromIntegral ht + fromIntegral asc) `div` 2) name' forM tws maketab - return [(W.focus s, shrink conf sc)] + return $ map (\w -> (w,shrink sc)) ws type Shrinker = String -> [String] @@ -35,7 +35,7 @@ import StackSet ( focus, up, down) -- > twoPane defaultDelta (1%2) twoPane :: Rational -> Rational -> Layout a -twoPane delta split = Layout { doLayout = \r s -> return $ arrange r s, modifyLayout = message } +twoPane delta split = Layout { doLayout = \r s -> return (arrange r s,Nothing), modifyLayout = message } where arrange rect st = case reverse (up st) of (master:_) -> [(master,left),(focus st,right)] |