Tabbed: reintroduced shrinker configuration option and removed the unneeded Read instance

darcs-hash:20070930131936-32816-354ee38e34c345b573947fba614d554ff8140a09.gz

1 files changed, 36 insertions, 33 deletions

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