diff options
| -rw-r--r-- | XMonad/Config/Droundy.hs | 22 | ||||
| -rw-r--r-- | XMonad/Layout/Tabbed.hs | 51 |
2 files changed, 50 insertions, 23 deletions
diff --git a/XMonad/Config/Droundy.hs b/XMonad/Config/Droundy.hs index 856db86..27e1987 100644 --- a/XMonad/Config/Droundy.hs +++ b/XMonad/Config/Droundy.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures -fglasgow-exts #-} ----------------------------------------------------------------------------- -- | -- Copyright : (c) Spencer Janssen 2007 @@ -6,12 +6,12 @@ -- ------------------------------------------------------------------------ -module XMonad.Config.Droundy where +module XMonad.Config.Droundy ( config, mytab ) where -- -- Useful imports -- -import XMonad hiding (keys) +import XMonad hiding (keys, config) import qualified XMonad (keys) import XMonad.Config ( defaultConfig ) @@ -129,5 +129,19 @@ config = defaultConfig , XMonad.modMask = mod1Mask , XMonad.keys = keys } - where mytab = tabbed shrinkText defaultTConf +mytab = tabbed CustomShrink defaultTConf + +instance Shrinker CustomShrink where + shrinkIt shr s | Just s' <- dropFromTail " " s = shrinkIt shr s' + shrinkIt shr s | Just s' <- dropFromTail "- Iceweasel" s = shrinkIt shr s' + shrinkIt _ s | n > 9 = s : map cut [2..(halfn-3)] ++ shrinkIt shrinkText s + where n = length s + halfn = n `div` 2 + rs = reverse s + cut x = take (halfn - x) s ++ "..." ++ reverse (take (halfn-x) rs) + shrinkIt _ s = shrinkIt shrinkText s + +dropFromTail :: String -> String -> Maybe String +dropFromTail t s | drop (length s - length t) s == t = Just $ take (length s - length t) s + | otherwise = Nothing diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs index 92ef150..f704bbb 100644 --- a/XMonad/Layout/Tabbed.hs +++ b/XMonad/Layout/Tabbed.hs @@ -18,8 +18,9 @@ module XMonad.Layout.Tabbed ( -- * Usage: -- $usage tabbed - , shrinkText + , shrinkText, CustomShrink(CustomShrink) , TConf (..), defaultTConf + , Shrinker(..) ) where import Control.Monad.State ( gets ) @@ -68,8 +69,8 @@ import XMonad.Util.XUtils -- %import XMonad.Layout.Tabbed -- %layout , tabbed shrinkText defaultTConf -tabbed :: Shrinker -> TConf -> Tabbed a -tabbed s t = Tabbed (I Nothing) (I (Just s)) t +tabbed :: Shrinker s => s -> TConf -> Tabbed s a +tabbed s t = Tabbed (I Nothing) s t data TConf = TConf { activeColor :: String @@ -100,17 +101,17 @@ data TabState = , fontS :: FontStruct -- FontSet } -data Tabbed a = - Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf +data Tabbed s a = + Tabbed (Invisible Maybe TabState) s TConf deriving (Show, Read) -instance LayoutClass Tabbed Window where +instance Shrinker s => LayoutClass (Tabbed s) Window where 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 :: Shrinker s => Invisible Maybe TabState -> s -> TConf + -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed s 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) @@ -129,16 +130,16 @@ doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do 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 :: Shrinker s => Tabbed s Window -> SomeMessage -> X (Maybe (Tabbed s Window)) 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 mapM_ deleteWindow $ map fst tws releaseFont (fontS st) - return $ Just $ Tabbed (I Nothing) (I Nothing) conf + return $ Just $ Tabbed (I Nothing) ishr conf handleMess _ _ = return Nothing -handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X () +handleEvent :: Shrinker s => s -> TConf -> TabState -> Event -> X () -- button press handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) @@ -181,7 +182,7 @@ 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 :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () +updateTab :: Shrinker s => s -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () updateTab ishr c fs wh (tabw,ow) = do nw <- getName ow let ht = fromIntegral $ tabSize c :: Dimension @@ -191,7 +192,7 @@ updateTab ishr c fs wh (tabw,ow) = do (bc',borderc',tc') <- focusColor ow (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) (activeColor c, activeBorderColor c, activeTextColor c) - let s = fromIMaybe shrinkText ishr + let s = shrinkIt 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 @@ -200,15 +201,27 @@ shrink :: TConf -> Rectangle -> Rectangle shrink c (Rectangle x y w h) = Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c)) -type Shrinker = String -> [String] - -shrinkWhile :: Shrinker -> (String -> Bool) -> String -> String +shrinkWhile :: (String -> [String]) -> (String -> Bool) -> String -> String shrinkWhile sh p x = sw $ sh x where sw [n] = n sw [] = "" sw (n:ns) | p n = sw ns | otherwise = n -shrinkText :: Shrinker -shrinkText "" = [""] -shrinkText cs = cs : shrinkText (init cs) + +data CustomShrink = CustomShrink +instance Show CustomShrink where show _ = "" +instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)] + +class (Read s, Show s) => Shrinker s where + shrinkIt :: s -> String -> [String] + +data DefaultShrinker = DefaultShrinker +instance Show DefaultShrinker where show _ = "" +instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)] +instance Shrinker DefaultShrinker where + shrinkIt _ "" = [""] + shrinkIt s cs = cs : shrinkIt s (init cs) + +shrinkText :: DefaultShrinker +shrinkText = DefaultShrinker |