1 files changed, 124 insertions, 0 deletions
diff --git a/XMonad/Stockholm/Font.hs b/XMonad/Stockholm/Font.hs
new file mode 100644
index 0000000..b30a1e7
--- /dev/null
+++ b/XMonad/Stockholm/Font.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE CPP #-}
+
+module XMonad.Stockholm.Font
+    ( printStringCentered
+    , printStringXMF'
+    ) where
+
+import XMonad
+import XMonad.Util.Font
+
+
+printStringCentered :: (Functor m, MonadIO m)
+                    => Display -> Drawable -> XMonadFont
+                    -> GC -> Rectangle -> String
+                    -> m ()
+printStringCentered d p xmf gc r s = do
+    let x = rect_x r
+        y = rect_y r
+        w = rect_width r
+        h = rect_height r
+
+    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)
+        text_h = text_ascent
+
+    printStringXMF' d p xmf gc "" "" text_x text_y s
+
+
+-- 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
+    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
+    --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+    --tv setForeground d gc fc'
+    --tv setBackground d gc bc'
+    io $ wcDrawImageString d p fs gc x y s
+#ifdef XFT
+printStringXMF' dpy drw fs@(Xft font) gc fc bc x y s = do
+  let screen   = defaultScreenOfDisplay dpy
+      colormap = defaultColormapOfScreen screen
+      visual   = defaultVisualOfScreen screen
+  --tv bcolor <- stringToPixel dpy bc
+  (a,d)  <- textExtentsXMF fs s
+  gi <- io $ xftTextExtents dpy font s
+  --tv io $ setForeground dpy gc bcolor
+  io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
+                                (y - fi a)
+                                (fi $ xglyphinfo_xOff gi)
+                                (fi $ a + d)
+  io $ withXftDraw dpy drw visual colormap $
+         \draw -> withXftColorName dpy visual colormap fc $
+                   \color -> xftDrawString draw color font x y s
+#endif
+
+
+
+
+
+-- --my_printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
+-- --            -> Position -> Position -> String  -> m ()
+-- my_printStringXMF (Core fs) d p gc x y s = 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
+-- my_printStringXMF (Utf8 fs) d p gc x y s = do
+--     -- [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+--     -- setForeground d gc fc'
+--     -- setBackground d gc bc'
+--     wcDrawImageString d p fs gc x y s
+-- #ifdef XFT
+-- my_printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do
+--   let screen   = defaultScreenOfDisplay dpy
+--       colormap = defaultColormapOfScreen screen
+--       visual   = defaultVisualOfScreen screen
+--   bcolor <- stringToPixel dpy bc
+--   (a,d)  <- textExtentsXMF fs s
+--   gi <- io $ xftTextExtents dpy font s
+--   io $ setForeground dpy gc bcolor
+--   io $ fillRectangle dpy drw gc (x - fromIntegral (xglyphinfo_x gi))
+--                                 (y - fromIntegral a)
+--                                 (fromIntegral $ xglyphinfo_xOff gi)
+--                                 (fromIntegral $ a + d)
+--   io $ withXftDraw dpy drw visual colormap $
+--          \draw -> withXftColorName dpy visual colormap fc $
+--                    \color -> xftDrawString draw color font x y s
+-- #endif
+
+
+
+-- --textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
+-- my_textWidthXMF _   (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s
+-- my_textWidthXMF _   (Core fs) s = return $ fromIntegral $ textWidth fs s
+-- #ifdef XFT
+-- my_TextWidthXMF dpy (Xft xftdraw) s = liftIO $ do
+--     gi <- xftTextExtents dpy xftdraw s
+--     return $ xglyphinfo_xOff gi
+-- #endif
+-- 
+-- my_textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32)
+-- my_textExtentsXMF (Utf8 fs) s = do
+--   let (_,rl)  = wcTextExtents fs s
+--       ascent  = fromIntegral $ - (rect_y rl)
+--       descent = fromIntegral $ rect_height rl + (fromIntegral $ rect_y rl)
+--   return (ascent, descent)
+-- my_textExtentsXMF (Core fs) s = do
+--   let (_,a,d,_) = textExtents fs s
+--   return (a,d)
+-- #ifdef XFT
+-- my_textExtentsXMF (Xft xftfont) _ = io $ do
+--   ascent  <- fromIntegral `fmap` xftfont_ascent  xftfont
+--   descent <- fromIntegral `fmap` xftfont_descent xftfont
+--   return (ascent, descent)
+-- #endif