Port XPrompt to XMonad.Util.Font, various other refactorings

darcs-hash:20071116232743-a5988-555816e43cf5559966bee4c22e21e8a2f46edb92.gz

4 files changed, 45 insertions, 57 deletions

diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs
index 6388a2e..9bd0d35 100644
--- a/XMonad/Layout/WindowNavigation.hs
+++ b/XMonad/Layout/WindowNavigation.hs
@@ -112,13 +112,13 @@ configurableNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing))
 
 instance LayoutModifier WindowNavigation Window where
     redoLayout (WindowNavigation conf (I state)) rscr s wrs =
-        do XConf { normalBorder = nbc, focusedBorder = fbc } <- ask
+        do XConf { normalBorder = nbc, focusedBorder = fbc, display = dpy } <- ask
            [uc,dc,lc,rc] <-
                case brightness conf of
                Just frac -> do myc <- averagePixels fbc nbc frac
                                return [myc,myc,myc,myc]
-               Nothing -> mapM stringToPixel [upColor conf, downColor conf,
-                                              leftColor conf, rightColor conf]
+               Nothing -> mapM (stringToPixel dpy) [upColor conf, downColor conf,
+                                                    leftColor conf, rightColor conf]
            let dirc U = uc
                dirc D = dc
                dirc L = lc
diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs
index 8330316..dd88d75 100644
--- a/XMonad/Prompt.hs
+++ b/XMonad/Prompt.hs
@@ -29,7 +29,6 @@ module XMonad.Prompt (
                              -- $xutils
                              , mkUnmanagedWindow
                              , fillDrawable
-                             , printString
                              -- * Other Utilities
                              -- $utils
                              , getLastWord
@@ -49,7 +48,7 @@ import qualified XMonad.StackSet as W
 import XMonad.Util.Font
 import XMonad.Util.XSelection (getSelection)
 
-import Control.Arrow ((***),(&&&))
+import Control.Arrow ((&&&))
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.Bits
@@ -80,7 +79,7 @@ data XPState =
         , complWinDim        :: Maybe ComplWindowDim
         , completionFunction :: String -> IO [String]
         , gcon               :: GC
-        , fontS              :: FontStruct
+        , fontS              :: XMonadFont
         , xptype             :: XPType
         , command            :: String
         , offset             :: Int
@@ -143,7 +142,7 @@ defaultXPConfig =
 type ComplFunction = String -> IO [String]
 
 initState :: XPrompt p => Display -> Window -> Window -> Rectangle -> ComplFunction
-          -> GC -> FontStruct -> p -> [History] -> XPConfig -> XPState
+          -> GC -> XMonadFont -> p -> [History] -> XPConfig -> XPState
 initState d rw w s compl gc fonts pt h c =
     XPS d rw w s Nothing Nothing compl gc fonts (XPT pt) "" 0 h c
 
@@ -169,12 +168,11 @@ mkXPrompt t conf compl action = do
   gc <- liftIO $ createGC d w
   liftIO $ setGraphicsExposures d gc False
   (hist,h) <- liftIO $ readHistory
-  fs <- initCoreFont (font conf)
-  liftIO $ setFont d gc $ fontFromFontStruct fs
+  fs <- initXMF (font conf)
   let st = initState d rw w s compl gc fs (XPT t) hist conf
   st' <- liftIO $ execStateT runXP st
 
-  releaseCoreFont fs
+  releaseXMF fs
   liftIO $ freeGC d gc
   liftIO $ hClose h
   when (command st' /= "") $ do
@@ -444,18 +442,19 @@ printPrompt drw = do
                  else let (a,b) = (splitAt off com)
                       in (prt ++ a, [head b], tail b)
       ht = height c
-      (fsl,psl) = (textWidth fs *** textWidth fs) (f,p)
-  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Core fs) str
+  fsl <- io $ textWidthXMF (dpy st) fs f
+  psl <- io $ textWidthXMF (dpy st) fs p
+  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) fs str
   let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
       x = (asc + desc) `div` 2
-  fgcolor <- io $ initColor d $ fgColor c
-  bgcolor <- io $ initColor d $ bgColor c
+
+  let draw = printStringXMF d drw fs gc
   -- print the first part
-  io $ printString d drw gc fgcolor bgcolor x y f
+  draw (fgColor c) (bgColor c) x y f
   -- reverse the colors and print the "cursor" ;-)
-  io $ printString d drw gc bgcolor fgcolor (x + fsl) y p
+  draw (bgColor c) (fgColor c) (x + fromIntegral fsl) y p
   -- reverse the colors and print the rest of the string
-  io $ printString d drw gc fgcolor bgcolor (x + fsl + psl) y ss
+  draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss
 
 -- Completions
 
@@ -500,7 +499,8 @@ getComplWinDim compl = do
       wh = rect_width scr
       ht = height c
 
-  let max_compl_len =  (fi ht `div` 2) + (maximum . map (textWidth fs) $ compl)
+  tws <- mapM (textWidthXMF (dpy st) fs) compl
+  let max_compl_len =  fromIntegral ((fi ht `div` 2) + maximum tws)
       columns = max 1 $ wh `div` (fi max_compl_len)
       rem_height =  rect_height scr - ht
       (rows,r) = (length compl) `divMod` fi columns
@@ -511,7 +511,7 @@ getComplWinDim compl = do
       (x,y) = case position c of
                 Top -> (0,ht)
                 Bottom -> (0, (0 + rem_height - actual_height))
-  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) (Core fs) $ head compl
+  (_,asc,desc,_) <- io $ textExtentsXMF (dpy st) fs $ head compl
   let yp = fi $ (ht + fi (asc - desc)) `div` 2
       xp = (asc + desc) `div` 2
       yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
@@ -528,7 +528,6 @@ drawComplWin w compl = do
       bw = promptBorderWidth c
       gc = gcon st
   bgcolor <- io $ initColor d (bgColor c)
-  fgcolor <- io $ initColor d (fgColor c)
   border  <- io $ initColor d (borderColor c)
 
   (_,_,wh,ht,xx,yy) <- getComplWinDim compl
@@ -537,7 +536,7 @@ drawComplWin w compl = do
                          (defaultDepthOfScreen scr)
   io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
   let ac = splitInSubListsAt (length yy) (take ((length xx) * (length yy)) compl)
-  printComplList d p gc fgcolor bgcolor xx yy ac
+  printComplList d p gc (fgColor c) (bgColor c) xx yy ac
   io $ copyArea d p w gc 0 0 wh ht 0 0
   io $ freePixmap d p
 
@@ -558,7 +557,7 @@ redrawComplWin compl = do
             Nothing -> recreate
      else destroyComplWin
 
-printComplList :: Display -> Drawable -> GC -> Pixel -> Pixel
+printComplList :: Display -> Drawable -> GC -> String -> String
                -> [Position] -> [Position] -> [[String]] -> XP ()
 printComplList _ _ _ _ _ _ _ [] = return ()
 printComplList _ _ _ _ _ [] _ _ = return ()
@@ -566,7 +565,7 @@ printComplList d drw gc fc bc (x:xs) y (s:ss) = do
   printComplColumn d drw gc fc bc x y s
   printComplList d drw gc fc bc xs y ss
 
-printComplColumn :: Display -> Drawable -> GC -> Pixel -> Pixel
+printComplColumn :: Display -> Drawable -> GC -> String -> String
                  -> Position -> [Position] -> [String] -> XP ()
 printComplColumn _ _ _ _ _ _ _ [] = return ()
 printComplColumn _ _ _ _ _ _ [] _ = return ()
@@ -574,15 +573,14 @@ printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do
   printComplString d drw gc fc bc x y s
   printComplColumn d drw gc fc bc x yy ss
 
-printComplString :: Display -> Drawable -> GC -> Pixel -> Pixel
+printComplString :: Display -> Drawable -> GC -> String -> String
                  -> Position -> Position -> String  -> XP ()
 printComplString d drw gc fc bc x y s = do
   st <- get
   if s == getLastWord (command st)
-     then do bhc <- io $ initColor d (bgHLight $ config st)
-             fhc <- io $ initColor d (fgHLight $ config st)
-             io $ printString d drw gc fhc bhc x y s
-     else io $ printString d drw gc fc bc x y s
+     then printStringXMF d drw (fontS st) gc
+                            (fgHLight $ config st) (bgHLight $ config st) x y s
+     else printStringXMF d drw (fontS st) gc fc bc x y s
 
 -- History
 
@@ -624,14 +622,6 @@ writeHistory hist = do
 
 -- $xutils
 
--- | Prints a string on a 'Drawable'
-printString :: Display -> Drawable -> GC -> Pixel -> Pixel
-            -> Position -> Position -> String -> IO ()
-printString d drw gc fc bc x y s = do
-  setForeground d gc fc
-  setBackground d gc bc
-  drawImageString d drw gc x y s
-
 -- | Fills a 'Drawable' with a rectangle and a border
 fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
              -> Dimension -> Dimension -> Dimension -> IO ()
diff --git a/XMonad/Util/Font.cpphs b/XMonad/Util/Font.cpphs
index 56fe43e..496691b 100644
--- a/XMonad/Util/Font.cpphs
+++ b/XMonad/Util/Font.cpphs
@@ -52,12 +52,10 @@ data XMonadFont = Core FontStruct
 
 -- | Get the Pixel value for a named color: if an invalid name is
 -- given the black pixel will be returned.
-stringToPixel :: String -> X Pixel
-stringToPixel s = do
-  d <- asks display
-  io $ catch (getIt d) (fallBack d)
-    where getIt    d = initColor d s
-          fallBack d = const $ return $ blackPixel d (defaultScreen d)
+stringToPixel :: MonadIO m => Display -> String -> m Pixel
+stringToPixel d s = liftIO $ catch getIt fallBack
+    where getIt    = initColor d s
+          fallBack = const $ return $ blackPixel d (defaultScreen d)
 
 
 -- | Given a fontname returns the font structure. If the font name is
@@ -99,18 +97,18 @@ releaseXMF (Xft xftfont) = do
   io $ xftFontClose dpy xftfont
 #endif
 
-textWidthXMF :: Display -> XMonadFont -> String -> IO Int
+textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
 textWidthXMF _   (Core fs) s = return $ fi $ textWidth fs s
 #ifdef XFT
-textWidthXMF dpy (Xft xftdraw) s = do
+textWidthXMF dpy (Xft xftdraw) s = liftIO $ do
     gi <- xftTextExtents dpy xftdraw s
     return $ xglyphinfo_width gi
 #endif
 
-textExtentsXMF :: Display -> XMonadFont -> String -> IO (FontDirection,Int32,Int32,CharStruct)
+textExtentsXMF :: MonadIO m => Display -> XMonadFont -> String -> m (FontDirection,Int32,Int32,CharStruct)
 textExtentsXMF _ (Core fs) s = return $ textExtents fs s
 #ifdef XFT
-textExtentsXMF _ (Xft xftfont) _ = do
+textExtentsXMF _ (Xft xftfont) _ = liftIO $ do
     ascent <- xftfont_ascent xftfont
     descent <- xftfont_descent xftfont
     return (error "Font direction touched", fi ascent, fi descent, error "Font overall size touched")
@@ -134,21 +132,21 @@ stringPosition fs (Rectangle _ _ w h) al s = do
   return (x,y)
 
 
-printStringXMF :: Display -> Drawable -> XMonadFont -> GC -> String -> String
-            -> Position -> Position -> String  -> X ()
-printStringXMF d p (Core fs) gc fc bc x y s = do
-         io $ setFont d gc $ fontFromFontStruct fs
-         [fc',bc'] <- mapM stringToPixel [fc,bc]
-         io $ setForeground   d gc fc'
-         io $ setBackground   d gc bc'
-         io $ drawImageString d p gc x y s
+printStringXMF :: MonadIO m => Display -> Drawable -> XMonadFont -> GC -> String -> String
+            -> Position -> Position -> String  -> m ()
+printStringXMF d p (Core fs) gc fc bc x y s = liftIO $ do
+         setFont d gc $ fontFromFontStruct fs
+         [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+         setForeground   d gc fc'
+         setBackground   d gc bc'
+         drawImageString d p gc x y s
 
 #ifdef XFT
 printStringXMF dpy drw (Xft font) _ fc _ x y s = do
   let screen = defaultScreenOfDisplay dpy;
       colormap = defaultColormapOfScreen screen;
       visual = defaultVisualOfScreen screen;
-  io $ withXftDraw dpy drw visual colormap $
+  liftIO $ withXftDraw dpy drw visual colormap $
          \draw -> withXftColorName dpy visual colormap fc $
                    \color -> xftDrawString draw color font x y s
 #endif
diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs
index 9f4bc69..e53d371 100644
--- a/XMonad/Util/XUtils.hs
+++ b/XMonad/Util/XUtils.hs
@@ -53,7 +53,7 @@ createNewWindow :: Rectangle -> Maybe EventMask -> String -> X Window
 createNewWindow (Rectangle x y w h) m col = do
   d   <- asks display
   rw  <- asks theRoot
-  c <- stringToPixel col
+  c <- stringToPixel d col
   win <- io $ createSimpleWindow d rw x y w h 0 c c
   case m of
     Just em -> io $ selectInput d win em
@@ -116,7 +116,7 @@ paintWindow' win (Rectangle x y wh ht) bw color b_color str = do
   gc <- io $ createGC d p
   -- draw
   io $ setGraphicsExposures d gc False
-  [color',b_color'] <- mapM stringToPixel [color,b_color]
+  [color',b_color'] <- mapM (stringToPixel d) [color,b_color]
   -- we start with the border
   io $ setForeground d gc b_color'
   io $ fillRectangle d p gc 0 0 wh ht