Added basic rendering functions

6 files changed, 185 insertions, 17 deletions

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 <X11/Xutil.h>
+#include <cairo.h>
+#include <cairo-xlib.h>
+
+
+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]