From 5c9c99b41ce1ecfee70071ecd3b369855b72d259 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 13 Jul 2011 02:13:01 +0200 Subject: Added basic rendering functions --- lib/Phi/Bindings/Util.hsc | 44 +++++++++++++++++++++++++++ lib/Phi/Border.hs | 77 +++++++++++++++++++++++++++++++++++++++++++++++ lib/Phi/Panel.hs | 12 ++++++++ lib/Phi/X11.hs | 57 +++++++++++++++++++++++++++++------ lib/Phi/X11/AtomList.hs | 1 - lib/Phi/X11/Atoms.hs | 11 +++---- 6 files changed, 185 insertions(+), 17 deletions(-) create mode 100644 lib/Phi/Bindings/Util.hsc create mode 100644 lib/Phi/Border.hs (limited to 'lib') diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc new file mode 100644 index 0000000..5058a8b --- /dev/null +++ b/lib/Phi/Bindings/Util.hsc @@ -0,0 +1,44 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Phi.Bindings.Util ( setClassHint + , createXlibSurface + ) where + + +#include +#include +#include + + +import Foreign.C.String (withCString) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Storable + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Graphics.Rendering.Cairo.Types + + +foreign import ccall unsafe "X11/Xutil.h XSetClassHint" + xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO () + +setClassHint :: Display -> Window -> ClassHint -> IO () +setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p -> + withCString (resName hint) $ \res_name -> + withCString (resClass hint) $ \res_class -> do + (#poke XClassHint, res_name) p res_name + (#poke XClassHint, res_class) p res_class + xSetClassHint disp wnd p + +foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create" + xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface) + +createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface +createXlibSurface dpy drawable visual width height = do + surfacePtr <- xlibSurfaceCreate dpy drawable visual width height + surface <- mkSurface surfacePtr + manageSurface surface + return surface diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs new file mode 100644 index 0000000..42a0e8e --- /dev/null +++ b/lib/Phi/Border.hs @@ -0,0 +1,77 @@ +module Phi.Border ( BorderWidth(..) + , simpleBorderWidth + , border + ) where + +import Phi.Panel + +import Graphics.Rendering.Cairo + + +data BorderWidth = BorderWidth { borderTop :: !Int + , borderRight :: !Int + , borderBottom :: !Int + , borderLeft :: !Int + } + +simpleBorderWidth :: Int -> BorderWidth +simpleBorderWidth w = BorderWidth w w w w + +borderH :: BorderWidth -> Int +borderH bw = borderLeft bw + borderRight bw + +borderV :: BorderWidth -> Int +borderV bw = borderTop bw + borderBottom bw + +data Border = Border { margin :: !BorderWidth + , borderWidth :: !Int + , padding :: !BorderWidth + , borderColor :: !Color + , backgroundColor :: !Color + , cornerRadius :: !Double + , borderWeight :: !Float + , content :: !Panel + } + +instance PanelClass Border where + minSize border = minSize c + borderH p + 2*bw + borderH m + where + m = margin border + bw = borderWidth border + p = padding border + c = content border + + weight border = borderWeight border + + render border w h = do + newPath + arc (x + width - radius) (y + radius) radius (-pi/2) 0 + arc (x + width - radius) (y + height - radius) radius 0 (pi/2) + arc (x + radius) (y + height - radius) radius (pi/2) pi + arc (x + radius) (y + radius) radius pi (pi*3/2) + closePath + + setSourceRGBA fr fg fb fa + fillPreserve + + setSourceRGBA br bg bb ba + setLineWidth $ fromIntegral bw + stroke + where + m = margin border + bw = borderWidth border + p = padding border + c = content border + radius = cornerRadius border + + x = (fromIntegral $ borderLeft m) + (fromIntegral bw)/2 + y = (fromIntegral $ borderTop m) + (fromIntegral bw)/2 + width = fromIntegral $ w - borderH m - bw + height = fromIntegral $ h - borderV m - bw + + (br, bg, bb, ba) = borderColor border + (fr, fg, fb, fa) = backgroundColor border + + +border :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> Panel -> Panel +border m bw p border bc cr w c = Panel $ Border m bw p border bc cr w c \ No newline at end of file diff --git a/lib/Phi/Panel.hs b/lib/Phi/Panel.hs index b15f6ab..d54124f 100644 --- a/lib/Phi/Panel.hs +++ b/lib/Phi/Panel.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} module Phi.Panel ( Position(..) + , Color , Panel(..) , PanelClass(..) , (<~>) @@ -12,14 +13,21 @@ module Phi.Panel ( Position(..) import Data.Function import Data.Monoid +import Graphics.Rendering.Cairo + + data Position = Top | Bottom +type Color = (Double, Double, Double, Double) + class PanelClass a where minSize :: a -> Int weight :: a -> Float weight _ = 0 + render :: a -> Int -> Int -> Render () + data Panel = forall a. PanelClass a => Panel a | CompoundPanel [Panel] instance Monoid Panel where @@ -38,6 +46,9 @@ instance PanelClass Panel where weight (Panel p) = weight p weight (CompoundPanel panels) = sum $ map weight panels + + render (Panel p) w h = render p w h + render (CompoundPanel panels) _ _ = return () (<~>) :: Panel -> Panel -> Panel (<~>) = mappend @@ -56,6 +67,7 @@ data Separator = Separator Int Float instance PanelClass Separator where minSize (Separator s _) = s weight (Separator _ w) = w + render (Separator _ _) _ _ = return () separator :: Int -> Float -> Panel separator s w = Panel $ Separator s w diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 2645ac2..dd75484 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -9,6 +9,8 @@ import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama +import Graphics.Rendering.Cairo + import Control.Monad import Data.Maybe import Data.Bits @@ -19,6 +21,7 @@ import Control.Monad.Trans import qualified Phi.Panel as Panel import Phi.X11.Atoms +import qualified Phi.Bindings.Util as Util data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle] } @@ -29,6 +32,8 @@ data PhiState = PhiState { phiRootPixmap :: Pixmap data PanelState = PanelState { panelWindow :: Window , panelGC :: GC + , panelPixmap :: Pixmap + , panelSurface :: Surface , panelArea :: Rectangle , panelScreenArea :: Rectangle } @@ -55,7 +60,7 @@ liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) liftIOContToPhi f c = do config <- ask state <- get - (a, state') <- liftIO $ f $ \x -> runPhi config state $ c x + (a, state') <- liftIO $ f $ runPhi config state . c put state' return a @@ -63,6 +68,7 @@ liftIOContToPhi f c = do defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } + initPhi :: XConfig -> Panel.PanelConfig -> IO () initPhi xconfig config = do disp <- openDisplay [] @@ -97,9 +103,28 @@ initPhi xconfig config = do updatePanels :: Bool -> Phi () updatePanels redraw = do disp <- asks phiDisplay + panelConfig <- asks phiPanelConfig + rootPixmap <- gets phiRootPixmap panels <- gets phiPanels - forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0 + + forM_ panels $ \panel -> do + when redraw $ do + let surface = panelSurface panel + area = panelArea panel + -- draw background + liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0 + surfaceMarkDirty surface + + renderWith surface $ do + save + Panel.render (Panel.panelContent panelConfig) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area) + restore + + surfaceFlush surface + + -- copy pixmap to window + liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0 handlePropertyUpdate :: Event -> Phi () @@ -124,13 +149,22 @@ updateRootPixmap = do createPanel :: Rectangle -> Phi PanelState -createPanel screen = do +createPanel screenRect = do config <- asks phiPanelConfig disp <- asks phiDisplay - let rect = panelBounds config screen + let rect = panelBounds config screenRect + win <- createPanelWindow rect gc <- liftIO $ createGC disp win - return PanelState { panelWindow = win, panelGC = gc, panelArea = rect, panelScreenArea = screen } + + let screen = defaultScreen disp + depth = defaultDepth disp screen + visual = defaultVisual disp screen + + pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth + surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual + + return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect } createPanelWindow :: Rectangle -> Phi Window @@ -175,6 +209,9 @@ setPanelProperties panel = do , wmh_window_group = 0 } changeProperty32 disp (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) propModeReplace [ 2, 0, 0, 0, 0 ] + + Util.setClassHint disp (panelWindow panel) ClassHint { resName = "phi", resClass = "Phi" } + setStruts panel @@ -215,11 +252,11 @@ panelBounds config screenBounds = case Panel.panelPosition config of Panel.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config, rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) } -withRectangle :: Rectangle -> (Position -> Position -> Dimension -> Dimension -> a) -> a +withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a withRectangle r = withDimension r . withPosition r -withPosition :: Rectangle -> (Position -> Position -> a) -> a -withPosition r f = f (rect_x r) (rect_y r) +withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a +withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r) -withDimension :: Rectangle -> (Dimension -> Dimension -> a) -> a -withDimension r f = f (rect_width r) (rect_height r) +withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a +withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r) diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 60cd0c5..5965d69 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -15,4 +15,3 @@ atoms = [ "_XROOTPMAP_ID" , "_NET_WM_STRUT" , "_NET_WM_STRUT_PARTIAL" ] - diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs index a2708dd..38f8f3c 100644 --- a/lib/Phi/X11/Atoms.hs +++ b/lib/Phi/X11/Atoms.hs @@ -11,17 +11,15 @@ import Graphics.X11 import Phi.X11.AtomList -$(do - let atomsName = mkName "Atoms" - atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms - fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames - return [DataD [] atomsName [] [RecC atomsName fields] []] +$(let atomsName = mkName "Atoms" + atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms + fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames + in return [DataD [] atomsName [] [RecC atomsName fields] []] ) initAtoms :: Display -> IO Atoms initAtoms display = $(do - let atomsName = mkName "Atoms" atomNames <- mapM (\atom -> do varName <- newName ('_':atom) return (atom, mkName ("atom" ++ atom), varName) @@ -30,6 +28,7 @@ initAtoms display = \(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |] let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames + atomsName = mkName "Atoms" atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps return $ DoE $ atomInitializers ++ [atomsContruction] -- cgit v1.2.3