summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-13 02:13:01 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-13 02:13:01 +0200
commit5c9c99b41ce1ecfee70071ecd3b369855b72d259 (patch)
tree77e460321ef2375adeaec2e96c09484b5948cc0f /lib
parent982bcffcfeb074b4c1beff64ca7361a9a66ed273 (diff)
downloadphi-5c9c99b41ce1ecfee70071ecd3b369855b72d259.tar
phi-5c9c99b41ce1ecfee70071ecd3b369855b72d259.zip
Added basic rendering functions
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Bindings/Util.hsc44
-rw-r--r--lib/Phi/Border.hs77
-rw-r--r--lib/Phi/Panel.hs12
-rw-r--r--lib/Phi/X11.hs57
-rw-r--r--lib/Phi/X11/AtomList.hs1
-rw-r--r--lib/Phi/X11/Atoms.hs11
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]