From 695f96c7286824d887e1cc5aaaa5578a8ff8f3bc Mon Sep 17 00:00:00 2001 From: Andrea Rossato Date: Sun, 30 Sep 2007 15:19:36 +0200 Subject: Tabbed: reintroduced shrinker configuration option and removed the unneeded Read instance darcs-hash:20070930131936-32816-354ee38e34c345b573947fba614d554ff8140a09.gz --- Tabbed.hs | 69 +++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 36 insertions(+), 33 deletions(-) (limited to 'Tabbed.hs') diff --git a/Tabbed.hs b/Tabbed.hs index 0919af0..7ee77af 100644 --- a/Tabbed.hs +++ b/Tabbed.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | @@ -18,6 +17,7 @@ module XMonadContrib.Tabbed ( -- * Usage: -- $usage tabbed + , shrinkText , TConf (..), defaultTConf ) where @@ -63,8 +63,8 @@ import XMonadContrib.XUtils -- %import XMonadContrib.Tabbed -- %layout , tabbed defaultTConf -tabbed :: TConf -> Tabbed a -tabbed t = Tabbed (I Nothing) t +tabbed :: Shrinker -> TConf -> Tabbed a +tabbed s t = Tabbed (I Nothing) (I (Just s)) t data TConf = TConf { activeColor :: String @@ -96,26 +96,24 @@ data TabState = } data Tabbed a = - Tabbed (Invisible Maybe TabState) TConf + Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf deriving (Show, Read) instance Layout Tabbed Window where - doLayout (Tabbed mst conf) = doLay mst conf - handleMessage = handleMess - description _ = "Tabbed" - -instance Read FontStruct where - readsPrec _ _ = [] - -doLay :: Invisible Maybe TabState -> TConf -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window)) -doLay mst c sc (W.Stack w [] []) = do - whenIJust mst $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st) - return ([(w,sc)], Just $ Tabbed (I Nothing) c) -doLay mst conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do + doLayout (Tabbed ist ishr conf) = doLay ist ishr conf + handleMessage = handleMess + description _ = "Tabbed" + +doLay :: Invisible Maybe TabState -> Invisible Maybe Shrinker -> TConf + -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window)) +doLay ist ishr c sc (W.Stack w [] []) = do + whenIJust ist $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st) + return ([(w,sc)], Just $ Tabbed (I Nothing) ishr c) +doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do let ws = W.integrate s width = wid `div` fromIntegral (length ws) -- initialize state - st <- case mst of + st <- case ist of (I Nothing ) -> initState conf sc ws (I (Just ts)) -> if map snd (tabsWindows ts) == ws && scr ts == sc then return ts @@ -123,41 +121,41 @@ doLay mst conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do tws <- createTabs conf sc ws return (ts {scr = sc, tabsWindows = zip tws ws}) mapM_ showWindow $ map fst $ tabsWindows st - mapM_ (updateTab conf (fontS st) width) $ tabsWindows st - return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) conf)) + mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st + return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf)) handleMess :: Tabbed Window -> SomeMessage -> X (Maybe (Tabbed Window)) -handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) conf) m - | Just e <- fromMessage m :: Maybe Event = handleEvent conf st e >> return Nothing +handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m + | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e >> return Nothing | Just Hide == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing | Just ReleaseResources == fromMessage m = do d <- asks display mapM_ deleteWindow $ map fst tws io $ freeFont d (fontS st) - return $ Just $ Tabbed (I Nothing) conf + return $ Just $ Tabbed (I Nothing) (I Nothing) conf handleMess _ _ = return Nothing -handleEvent :: TConf -> TabState -> Event -> X () +handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X () -- button press -handleEvent conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl = do focus (fromJust $ lookup thisw tws) - updateTab conf fs width (thisw, fromJust $ lookup thisw tws) + updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws) where width = rect_width screen`div` fromIntegral (length tws) -handleEvent conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) (AnyEvent {ev_window = thisw, ev_event_type = t }) -- expose | thisw `elem` (map fst tws) && t == expose = do - updateTab conf fs width (thisw, fromJust $ lookup thisw tws) + updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws) -- propertyNotify | thisw `elem` (map snd tws) && t == propertyNotify = do let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw) - updateTab conf fs width tabwin + updateTab ishr conf fs width tabwin where width = rect_width screen`div` fromIntegral (length tws) -handleEvent _ _ _ = return () +handleEvent _ _ _ _ = return () initState :: TConf -> Rectangle -> [Window] -> X TabState initState conf sc ws = do @@ -177,8 +175,8 @@ createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows return (w:ws) -updateTab :: TConf -> FontStruct -> Dimension -> (Window,Window) -> X () -updateTab c fs wh (tabw,ow) = do +updateTab :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () +updateTab ishr c fs wh (tabw,ow) = do nw <- getName ow let ht = fromIntegral $ tabSize c :: Dimension focusColor win ic ac = (maybe ic (\focusw -> if focusw == win @@ -187,8 +185,9 @@ updateTab c fs wh (tabw,ow) = do (bc',borderc',tc') <- focusColor ow (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) (activeColor c, activeBorderColor c, activeTextColor c) - let name = shrinkWhile shrinkText (\n -> textWidth fs n > - fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + let s = fromIMaybe shrinkText ishr + name = shrinkWhile s (\n -> textWidth fs n > + fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name shrink :: TConf -> Rectangle -> Rectangle @@ -207,3 +206,7 @@ shrinkWhile sh p x = sw $ sh x shrinkText :: Shrinker shrinkText "" = [""] shrinkText cs = cs : shrinkText (init cs) + +fromIMaybe :: a -> Invisible Maybe a -> a +fromIMaybe _ (I (Just x)) = x +fromIMaybe a (I Nothing) = a -- cgit v1.2.3