From ec255a33cd8fa98e8dc325c475ba4d2c4e7a53d9 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Sat, 17 Nov 2007 00:27:43 +0100 Subject: Port XPrompt to XMonad.Util.Font, various other refactorings darcs-hash:20071116232743-a5988-555816e43cf5559966bee4c22e21e8a2f46edb92.gz --- XMonad/Layout/WindowNavigation.hs | 6 ++--- XMonad/Prompt.hs | 56 ++++++++++++++++----------------------- XMonad/Util/Font.cpphs | 36 ++++++++++++------------- XMonad/Util/XUtils.hs | 4 +-- 4 files changed, 45 insertions(+), 57 deletions(-) (limited to 'XMonad') 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 -- cgit v1.2.3