hello xmonad-0.12; silence all the warningsprism/tvcd/master

4 files changed, 75 insertions, 91 deletions

diff --git a/XMonad/Stockholm/Font.hs b/XMonad/Stockholm/Font.hs
index b30a1e7..ed801cc 100644
--- a/XMonad/Stockholm/Font.hs
+++ b/XMonad/Stockholm/Font.hs
@@ -22,8 +22,8 @@ printStringCentered d p xmf gc r s = do
     text_w <- textWidthXMF d xmf s
     (text_ascent, _) <- textExtentsXMF xmf s
 
-    let text_x = x + round ((fi w - fi text_w) / 2)
-        text_y = y + round ((fi h + fi text_h) / 2)
+    let text_x = x + round ((fi w - fi text_w) / (2 :: Double))
+        text_y = y + round ((fi h + fi text_h) / (2 :: Double))
         text_h = text_ascent
 
     printStringXMF' d p xmf gc "" "" text_x text_y s
@@ -32,13 +32,13 @@ printStringCentered d p xmf gc r s = do
 -- from xmonad-contrib's XMonad.Util.Font, (c) 2007 Andrea Rossato and Spencer Janssen
 printStringXMF' :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
             -> Position -> Position -> String  -> m ()
-printStringXMF' d p (Core fs) gc fc bc x y s = io $ do
+printStringXMF' d p (Core fs) gc _fc _bc x y s = io $ do
     setFont d gc $ fontFromFontStruct fs
     --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
     --tv setForeground d gc fc'
     --tv setBackground d gc bc'
     drawImageString d p gc x y s
-printStringXMF' d p (Utf8 fs) gc fc bc x y s = io $ do
+printStringXMF' d p (Utf8 fs) gc _fc _bc x y s = io $ do
     --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
     --tv setForeground d gc fc'
     --tv setBackground d gc bc'
@@ -59,6 +59,8 @@ printStringXMF' dpy drw fs@(Xft font) gc fc bc x y s = do
   io $ withXftDraw dpy drw visual colormap $
          \draw -> withXftColorName dpy visual colormap fc $
                    \color -> xftDrawString draw color font x y s
+#else
+printStringXMF' _ _ (Xft _) _ _ _ _ _ _ = undefined
 #endif
 
 
diff --git a/XMonad/Stockholm/Pager.hs b/XMonad/Stockholm/Pager.hs
index cdfa432..eb00832 100644
--- a/XMonad/Stockholm/Pager.hs
+++ b/XMonad/Stockholm/Pager.hs
@@ -1,6 +1,5 @@
 module XMonad.Stockholm.Pager
-    ( defaultPagerConfig
-    , defaultWindowColors
+    ( defaultWindowColors
     , defaultWorkspaceColors
     , MatchMethod(..)
     , pager
@@ -30,12 +29,12 @@ data PagerConfig = PagerConfig
     }
 
 
-defaultPagerConfig :: PagerConfig
-defaultPagerConfig = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors
+instance Default PagerConfig where
+    def = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors
 
 
 pager :: PagerConfig -> (String -> X ()) -> [String] -> X ()
-pager pc = rhombus defaultRhombusConfig
+pager pc = rhombus def
     { rc_font           = pc_font pc
     , rc_cellwidth      = pc_cellwidth pc
     , rc_margin         = pc_margin pc
@@ -98,7 +97,7 @@ pagerPaint ::
   -> Bool
   -> Bool
   -> X ()
-pagerPaint pc rc d p gc t r focus match current = do
+pagerPaint pc rc _ p gc t r foc match current = do
     ss <- gets windowset
 
     let x = rect_x r
@@ -107,14 +106,11 @@ pagerPaint pc rc d p gc t r focus match current = do
     urgents <- readUrgents
     let foci = map W.focus $ catMaybes $ map W.stack $ W.workspaces ss
 
-    let color = pc_windowColors pc focus match current -- :: Bool -> (String, String)
-        (_, _, _fg_color) = pc_workspaceColors pc focus match current
+    let color = pc_windowColors pc foc match current -- :: Bool -> (String, String)
+        (_, _, _fg_color) = pc_workspaceColors pc foc match current
 
-    fg_color <- stringToPixel d _fg_color
-
-    let r = screenRect $ W.screenDetail $ W.current ss
-    let a = fi (rect_width r) / fi (rect_height r)
-    let scale = fi (rc_cellwidth rc) / fi (rect_width r)
+    let sr = screenRect $ W.screenDetail $ W.current ss
+    let scale = fi (rc_cellwidth rc) / fi (rect_width sr)
 
     -- TODO whenNothing print error
     whenJust (findWorkspace t ss) $ \ ws -> do
@@ -129,14 +125,13 @@ pagerPaint pc rc d p gc t r focus match current = do
                 mapM_ (drawMiniWindow d p gc x y color' scale) (W.up s)
 
 drawMiniWindow
-    :: RealFrac a
-    => Display
+    :: Display
     -> Drawable
     -> GC
     -> Position
     -> Position
     -> (Window -> (String, String))
-    -> a
+    -> Double
     -> Window
     -> IO ()
 drawMiniWindow d p gc ox oy color s win = do
diff --git a/XMonad/Stockholm/Rhombus.hs b/XMonad/Stockholm/Rhombus.hs
index 93ecf07..b4d6861 100644
--- a/XMonad/Stockholm/Rhombus.hs
+++ b/XMonad/Stockholm/Rhombus.hs
@@ -1,21 +1,19 @@
 module XMonad.Stockholm.Rhombus
-    ( defaultRhombusConfig
-    , MatchMethod(..)
+    ( MatchMethod(..)
     , rhombus
     , RhombusConfig(..)
     , RhombusState(..)
     ) where
 
-import Control.Monad (forM_, zipWithM_)
+import Control.Monad (zipWithM_)
 import Data.Char
 import Data.List
 import Data.Ord
 import Data.Map (fromList)
-import Data.Maybe (isJust, fromJust)
-import XMonad
-import XMonad.StackSet hiding (filter)
+import Data.Maybe (fromJust)
+import XMonad hiding (keys)
+import XMonad.StackSet hiding (filter, tag)
 import XMonad.Util.Font
-import XMonad.Util.Image (drawIcon)
 import XMonad.Util.XUtils
 
 import XMonad.Stockholm.Submap
@@ -33,15 +31,25 @@ data RhombusConfig = RhombusConfig
     , rc_wrap           :: Bool
     , rc_colors         :: Bool -> Bool -> Bool -> (String, String, String)
     , rc_paint          :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
+    , rc_missAction     :: X ()
     }
 
 
 -- TODO currently xft is broken
-defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
-    where
-    stupidColors _ _ _ = ("red", "magenta", "yellow")
-    noPaint _ _ _ _ _ _ _ _ _ = return ()
-
+instance Default RhombusConfig where
+    def = RhombusConfig
+        { rc_font = "xft:Sans-8"
+        , rc_cellwidth = 100
+        , rc_margin = 0
+        , rc_matchmethod = MatchInfix
+        , rc_wrap = True
+        , rc_colors = stupidColors
+        , rc_paint = noPaint
+        , rc_missAction = return ()
+        }
+      where
+        stupidColors _ _ _ = ("red", "magenta", "yellow")
+        noPaint _ _ _ _ _ _ _ _ _ = return ()
 
 data RhombusState = RhombusState
     { rs_window     :: Window
@@ -81,14 +89,14 @@ rhombus rc viewFunc as = withGrabbedKeyboard $ do
 rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
 rhombusMode viewFunc rc rs =
     case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
-        Nothing -> redraw rc rs >> submapString def keys
+        Nothing -> redraw rc rs >> submapString defAction keys
         Just i -> removeRhombus rs >> viewFunc i
     where
-    def (ch:[]) | isPrint ch =
+    defAction (ch:[]) | isPrint ch =
         incSearchPushChar ch rs >>= rhombusMode viewFunc rc
 
-    def _ =
-        failbeep >> rhombusMode viewFunc rc rs
+    defAction _ =
+        rc_missAction rc >> rhombusMode viewFunc rc rs
 
     keys = fromList $
         [ ((0   , xK_BackSpace  ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
@@ -106,57 +114,55 @@ rhombusMode viewFunc rc rs =
     _S = shiftMask
 
 
--- TODO make failbeep configurable
-failbeep = spawn "beep -l 100 -f 500"
-
-
 goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
-goto RhombusConfig{rc_wrap=True}  xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs
-goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs
+goto rc xy rs =
+    maybe (rc_missAction rc >> return rs) return $ op xy rs
+  where
+    op = if rc_wrap rc then wrapFocus else moveFocus
 
 
 moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
 moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
-    let focus' = (x + dx, y + dy)
-    if elem focus' (reachableCoords rs)
-        then Just rs { rs_focus = focus' }
+    let foc' = (x + dx, y + dy)
+    if elem foc' (reachableCoords rs)
+        then Just rs { rs_focus = foc' }
         else Nothing
 
 
 wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
 
-wrapFocus (0, dy) rs@RhombusState{rs_focus=focus} = do
-    let column = sortBy (comparing snd) $ filter ((==) (fst focus) . fst) (reachableCoords rs)
-    i <- elemIndex focus column
+wrapFocus (0, dy) rs@RhombusState{rs_focus=foc} = do
+    let column = sortBy (comparing snd) $ filter ((==) (fst foc) . fst) (reachableCoords rs)
+    i <- elemIndex foc column
     return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }
 
-wrapFocus (dx, 0) rs@RhombusState{rs_focus=focus} = do
-    let column = sortBy (comparing fst) $ filter ((==) (snd focus) . snd) (reachableCoords rs)
-    i <- elemIndex focus column
+wrapFocus (dx, 0) rs@RhombusState{rs_focus=foc} = do
+    let column = sortBy (comparing fst) $ filter ((==) (snd foc) . snd) (reachableCoords rs)
+    i <- elemIndex foc column
     return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }
 
 wrapFocus _ _ = Nothing
 
 
 gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
-gotoPrevMatch rc rs@RhombusState{rs_focus=focus} = do
+gotoPrevMatch rc rs@RhombusState{rs_focus=foc} = do
     case reverse (matchingReachableCoords rc rs) of
-        [] -> failbeep >> return rs
+        [] -> rc_missAction rc >> return rs
         xs -> return rs
             { rs_focus = maybe (head xs)
                                (modIndex xs . (+1))
-                               (focus `elemIndex` xs)
+                               (foc `elemIndex` xs)
             }
 
 
 gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
-gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
+gotoNextMatch rc rs@RhombusState{rs_focus=foc} = do
     case matchingReachableCoords rc rs of
-        [] -> failbeep >> return rs
+        [] -> rc_missAction rc >> return rs
         xs -> return rs
             { rs_focus = maybe (head xs)
                                (modIndex xs . (+1))
-                               (focus `elemIndex` xs)
+                               (foc `elemIndex` xs)
             }
 
 
@@ -215,12 +221,12 @@ redraw rc rs = do
         -- TODO fixme
         color_black <- stringToPixel d "black"
 
-        forZipWithM_ tags (reachableCoords rs) $ \ tag oxy@(ox, oy) -> do
+        forZipWithM_ tags (reachableCoords rs) $ \tag oxy@(ox, oy) -> do
 
-            let focus   = oxy == rs_focus rs
-                match   = isXOf (rc_matchmethod rc) (rs_search rs) tag
-                current = tag == last tags
-                (_b_color, _bg_color, _fg_color) = rc_colors rc focus match current
+            let isFocused = oxy == rs_focus rs
+                isMatched = isXOf (rc_matchmethod rc) (rs_search rs) tag
+                isCurrent = tag == last tags
+                (_b_color, _bg_color, _fg_color) = rc_colors rc isFocused isMatched isCurrent
                 --cell_x = (ox * dx) + x - fi (cell_w `div` 2)
                 --cell_y = (oy * dy) + y - fi (cell_h `div` 2)
                 cell_x = (ox * dx) + tx + 1
@@ -246,7 +252,7 @@ redraw rc rs = do
                     coordModePrevious
 
             -- custom draw
-            paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) focus match current
+            paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) isFocused isMatched isCurrent
 
             -- paint text
             -- TODO custom paint text?
@@ -323,12 +329,10 @@ removeRhombus (RhombusState w _ fn _ _) = do
 
 wave :: [(Position, Position)]
 wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
-    where
-        wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
-        wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]
+    --where
+    --    wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
+    --    wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]
 
-commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
-commonPrefix _ _ = []
 
 
 isXOf :: MatchMethod -> String -> String -> Bool
@@ -336,32 +340,15 @@ isXOf MatchInfix  = isInfixOf
 isXOf MatchPrefix = isPrefixOf
 
 
-findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int
-findXIndex MatchInfix  = findInfixIndex
-findXIndex MatchPrefix = findPrefixIndex
-
-
-findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
-findInfixIndex needle haystack
-    = (\x -> if null x then Nothing else Just (fst $ head x))
-      . dropWhile (\(_,x) -> not $ isPrefixOf needle x)
-        $ zip [0..] (tails haystack)
-
-
-findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
-findPrefixIndex needle haystack =
-    if isPrefixOf needle haystack
-        then Just 0
-        else Nothing
-
-
 modIndex :: Integral i => [a] -> i -> a
 modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)
 
 
+forZipWithM_ :: Monad m => [a] -> [b] -> (a -> b -> m c) -> m ()
 forZipWithM_ a b f = zipWithM_ f a b
 
 
+withGrabbedKeyboard :: X () -> X ()
 withGrabbedKeyboard f = do
     XConf { theRoot = root, display = d } <- ask
     catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
diff --git a/XMonad/Stockholm/Submap.hs b/XMonad/Stockholm/Submap.hs
index 8648e6c..601afba 100644
--- a/XMonad/Stockholm/Submap.hs
+++ b/XMonad/Stockholm/Submap.hs
@@ -12,8 +12,8 @@ import XMonad hiding (keys)
 
 -- | Like 'XMonad.Actions.Submap.submapDefault', but provides the looked up string to the default action.
 submapString :: (String -> X ()) -> M.Map (KeyMask, KeySym) (X ()) -> X ()
-submapString def keys = do
-    XConf { theRoot = root, display = d } <- ask
+submapString defAction keys = do
+    XConf { display = d } <- ask
 
     (m, s, str) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do
         maskEvent d keyPressMask p
@@ -22,10 +22,10 @@ submapString def keys = do
         if isModifierKey keysym
             then nextkey
             else do
-                (mbKeysym, str) <- lookupString (asKeyEvent p)
+                (_, str) <- lookupString (asKeyEvent p)
                 return (m, keysym, str)
 
     -- Remove num lock mask and Xkb group state bits
     m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)
 
-    maybe (def str) id (M.lookup (m', s) keys)
+    maybe (defAction str) id (M.lookup (m', s) keys)