neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Converted core to XHB/XCB

Browse source
This commit is contained in:
Matthias Schiffer 2011-09-07 16:38:36 +02:00
parent 42d5f27d32
commit 15d9304e05
11 changed files with 433 additions and 368 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
csrc/SystrayErrorHandler.c
View file

@ -1,27 +0,0 @@
#include <SystrayErrorHandler.h>
static Window lastErrorWindow = 0;
static int systrayErrorHandler (Display *display, XErrorEvent *event)
{
if (event->error_code == BadWindow) {
lastErrorWindow = event->resourceid;
}
return 0;
}
void setSystrayErrorHandler (void)
{
lastErrorWindow = 0;
XSetErrorHandler(systrayErrorHandler);
}
Window getLastErrorWindow (void)
{
Window ret = lastErrorWindow;
lastErrorWindow = 0;
return ret;
}

17
lib/Phi/Bindings/SystrayErrorHandler.hsc
View file

@ -1,17 +0,0 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler
, getLastErrorWindow
) where
#include <SystrayErrorHandler.h>
import Graphics.X11.Xlib
foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler"
setSystrayErrorHandler :: IO ()
foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow"
getLastErrorWindow :: IO Window

90
lib/Phi/Bindings/Util.hsc
View file

@ -1,90 +0,0 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Phi.Bindings.Util ( setClassHint
, visualIDFromVisual
, putClientMessage
, Phi.Bindings.Util.getEvent
, createXlibSurface
) where
#include <X11/Xlib.h>
#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.Marshal.Array
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 "X11/Xlib.h XVisualIDFromVisual"
visualIDFromVisual :: Visual -> VisualID
putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
putClientMessage event window message_type messageData = do
setEventType event clientMessage
(#poke XClientMessageEvent, window) event window
(#poke XClientMessageEvent, message_type) event message_type
(#poke XClientMessageEvent, format) event (32 :: CInt)
pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData
foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
getEvent :: Display -> XEventPtr -> IO Event
getEvent display p = do
eventType <- get_EventType p
case True of
_ | eventType == clientMessage -> do
serial <- (#peek XClientMessageEvent, serial) p
send_event <- (#peek XClientMessageEvent, send_event) p
window <- (#peek XClientMessageEvent, window) p
message_type <- (#peek XClientMessageEvent, message_type) p
format <- (#peek XClientMessageEvent, format) p
let datPtr = (#ptr XClientMessageEvent, data) p
dat <- case (format::CInt) of
8 -> do a <- peekArray 20 datPtr
return $ map fromIntegral (a::[CUChar])
16 -> do a <- peekArray 10 datPtr
return $ map fromIntegral (a::[CUShort])
32 -> do a <- peekArray 5 datPtr
return $ map fromIntegral (a::[CULong])
return $ ClientMessageEvent { ev_event_type = eventType
, ev_serial = serial
, ev_send_event = send_event
, ev_event_display = display
, ev_window = window
, ev_message_type = message_type
, ev_data = dat
}
| otherwise -> Graphics.X11.Xlib.Extras.getEvent p
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

92
lib/Phi/Bindings/XCB.hsc Normal file
View file

@ -0,0 +1,92 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Phi.Bindings.XCB ( Connection
, connect
, createXCBSurface
, flush
, clearArea
) where
import Control.Monad
import Data.Int
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.Cairo.Types
import Graphics.XHB (toValue)
import Graphics.XHB.Gen.Xproto (DRAWABLE, WINDOW, VISUALTYPE(..))
#include <xcb/xcb.h>
#include <xcb/xproto.h>
#include <cairo-xcb.h>
data Connection = Connection (ForeignPtr Connection)
foreign import ccall "xcb/xcb.h xcb_connect" xcb_connect :: CString -> Ptr CInt -> IO (Ptr Connection)
foreign import ccall "xcb/xcb.h &xcb_disconnect" p_xcb_disconnect :: FunPtr (Ptr Connection -> IO ())
connect :: IO Connection
connect = do
conn <- xcb_connect nullPtr nullPtr
newForeignPtr p_xcb_disconnect conn >>= return . Connection
foreign import ccall "cairo-xlib.h cairo_xcb_surface_create"
cairo_xcb_surface_create :: Ptr Connection -> DRAWABLE -> Ptr VISUALTYPE -> CInt -> CInt -> IO (Ptr Surface)
instance Storable VISUALTYPE where
sizeOf _ = (#size xcb_visualtype_t)
alignment _ = alignment (undefined :: CInt)
peek _ = error "VISUALTYPE: peek not implemented"
poke vt (MkVISUALTYPE visual_id _class bits_per_rgb_value colormap_entries red_mask green_mask blue_mask) = do
(#poke xcb_visualtype_t, visual_id) vt visual_id
(#poke xcb_visualtype_t, _class) vt (toValue _class :: Word8)
(#poke xcb_visualtype_t, bits_per_rgb_value) vt bits_per_rgb_value
(#poke xcb_visualtype_t, colormap_entries) vt colormap_entries
(#poke xcb_visualtype_t, red_mask) vt red_mask
(#poke xcb_visualtype_t, green_mask) vt green_mask
(#poke xcb_visualtype_t, blue_mask) vt blue_mask
createXCBSurface :: Connection -> DRAWABLE -> VISUALTYPE -> CInt -> CInt -> IO Surface
createXCBSurface (Connection conn) drawable visual width height =
with visual $ \visualptr -> withForeignPtr conn $ \connptr -> do
surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr width height
surface <- mkSurface surfacePtr
manageSurface surface
return surface
foreign import ccall "xcb/xcb.h xcb_flush"
xcb_flush :: Ptr Connection -> IO ()
flush :: Connection -> IO ()
flush (Connection conn) = withForeignPtr conn xcb_flush
type VOID_COOKIE = CUInt
foreign import ccall "xcb/xcb.h xcb_request_check"
xcb_request_check :: Ptr Connection -> VOID_COOKIE -> IO (Ptr ())
requestCheck :: Ptr Connection -> VOID_COOKIE -> IO ()
requestCheck conn cookie = do
ret <- xcb_request_check conn cookie
when (ret /= nullPtr) $
free ret
foreign import ccall "xcb/xproto.h xcb_clear_area"
xcb_clear_area :: Ptr Connection -> Word8 -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO VOID_COOKIE
clearArea :: Connection -> Bool -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO ()
clearArea (Connection conn) exposures window x y width height = withForeignPtr conn $ \connptr -> do
cookie <- xcb_clear_area connptr (if exposures then 1 else 0) window x y width height
requestCheck connptr cookie

45
lib/Phi/Widget.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widget ( Display(..) module Phi.Widget ( XEvent(..)
, Display(..)
, withDisplay , withDisplay
, getAtoms , getAtoms
, XMessage(..) , XMessage(..)
@ -30,36 +31,38 @@ import Control.Monad.IO.Class
import Data.Maybe import Data.Maybe
import Data.Typeable import Data.Typeable
import qualified Graphics.X11.Xlib as Xlib import Graphics.XHB
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
import Phi.Phi import Phi.Phi
import Phi.X11.Atoms import Phi.X11.Atoms
data Display = Display !(MVar Xlib.Display) !Atoms data Display = Display !Connection !Atoms
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a newtype XEvent = XEvent SomeEvent deriving Typeable
withDisplay (Display dispvar _) f = do
disp <- liftIO $ takeMVar dispvar instance Show XEvent where
a <- f disp show _ = "XEvent (..)"
liftIO $ putMVar dispvar disp
return a
withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
withDisplay (Display conn _) f = f conn
getAtoms :: Display -> Atoms getAtoms :: Display -> Atoms
getAtoms (Display _ atoms) = atoms getAtoms (Display _ atoms) = atoms
data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable) data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int unionArea :: RECTANGLE -> RECTANGLE -> Int
unionArea a b = fromIntegral $ uw*uh unionArea a b = fromIntegral $ uw*uh
where where
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1) uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
uh = max 0 $ (min ay2 by2) - (max ay1 by1) uh = max 0 $ (min ay2 by2) - (max ay1 by1)
Xlib.Rectangle ax1 ay1 aw ah = a MkRECTANGLE ax1 ay1 aw ah = a
Xlib.Rectangle bx1 by1 bw bh = b MkRECTANGLE bx1 by1 bw bh = b
ax2 = ax1 + fromIntegral aw ax2 = ax1 + fromIntegral aw
ay2 = ay1 + fromIntegral ah ay2 = ay1 + fromIntegral ah
@ -71,22 +74,24 @@ unionArea a b = fromIntegral $ uw*uh
data SurfaceSlice = SurfaceSlice !Int !Surface data SurfaceSlice = SurfaceSlice !Int !Surface
class Eq s => Widget w s c | w -> s, w -> c where class Eq s => Widget w s c | w -> s, w -> c where
initWidget :: w -> Phi -> Display -> [(Xlib.Rectangle, Xlib.Window)] -> IO s initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s
initCache :: w -> c initCache :: w -> c
minSize :: w -> s -> Int -> Xlib.Rectangle -> Int minSize :: w -> s -> Int -> RECTANGLE -> Int
weight :: w -> Float weight :: w -> Float
weight _ = 0 weight _ = 0
render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)] render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)]
handleMessage :: w -> s -> Message -> s handleMessage :: w -> s -> Message -> s
handleMessage _ priv _ = priv handleMessage _ priv _ = priv
deriving instance Eq RECTANGLE
type IOCache = CacheArrow (Kleisli IO) type IOCache = CacheArrow (Kleisli IO)
type RenderCache s = IOCache (s, Int, Int, Int, Int, Xlib.Rectangle) Surface type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface
createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli createIOCache = lift . Kleisli
@ -98,8 +103,8 @@ runIOCache a = do
put cache' put cache'
return b return b
createRenderCache :: (s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()) createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Xlib.Rectangle) Surface -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
surface <- createImageSurface FormatARGB32 w h surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do renderWith surface $ do
@ -109,7 +114,7 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
f state x y w h screen f state x y w h screen
return surface return surface
renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)] renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
renderCached state x y w h screen = do renderCached state x y w h screen = do
cache <- get cache <- get
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen) (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)

300
lib/Phi/X11.hs
View file

@ -5,16 +5,19 @@ module Phi.X11 ( XConfig(..)
, runPhi , runPhi
) where ) where
import Graphics.X11.Xlib import Graphics.XHB
import Graphics.X11.Xlib.Extras import Graphics.XHB.Gen.Xinerama
import Graphics.X11.Xinerama import Graphics.XHB.Gen.Xproto
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
import Control.Monad import Control.Monad
import Data.Maybe
import Data.Bits import Data.Bits
import Data.Char import Data.Char
import Data.List
import Data.Maybe
import Data.Typeable
import Data.Word
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Concurrent import Control.Concurrent
@ -27,16 +30,18 @@ import System.Exit
import System.Posix.Signals import System.Posix.Signals
import System.Posix.Types import System.Posix.Types
import qualified Phi.Bindings.XCB as XCB
import Phi.Phi import Phi.Phi
import Phi.X11.Util
import qualified Phi.Types as Phi import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel import qualified Phi.Panel as Panel
import qualified Phi.Widget as Widget import qualified Phi.Widget as Widget
import Phi.Widget hiding (Display, handleMessage) import Phi.Widget hiding (Display, handleMessage)
import Phi.X11.Atoms import Phi.X11.Atoms
import qualified Phi.Bindings.Util as Util
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE])
} }
data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface
@ -47,10 +52,10 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su
, phiWidgetState :: !s , phiWidgetState :: !s
} }
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW
, panelPixmap :: !Pixmap , panelPixmap :: !PIXMAP
, panelArea :: !Rectangle , panelArea :: !RECTANGLE
, panelScreenArea :: !Rectangle , panelScreenArea :: !RECTANGLE
, panelWidgetCache :: !c , panelWidgetCache :: !c
} }
@ -76,27 +81,35 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
} }
getScreenInfo :: Connection -> IO [RECTANGLE]
getScreenInfo conn = do
exs <- queryScreens conn >>= getReply
case exs of
Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs
Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>=
return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h])
where
screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h
runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO () runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO ()
runPhi xconfig config widget = do runPhi xconfig config widget = do
xSetErrorHandler
phi <- initPhi phi <- initPhi
installHandler sigTERM (termHandler phi) Nothing installHandler sigTERM (termHandler phi) Nothing
installHandler sigINT (termHandler phi) Nothing installHandler sigINT (termHandler phi) Nothing
installHandler sigQUIT (termHandler phi) Nothing installHandler sigQUIT (termHandler phi) Nothing
disp <- openDisplay [] conn <- liftM fromJust connect
xcb <- XCB.connect
atoms <- initAtoms disp atoms <- initAtoms conn
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
bg <- createImageSurface FormatRGB24 1 1 bg <- createImageSurface FormatRGB24 1 1
dispmvar <- newMVar disp screens <- liftIO $ phiXScreenInfo xconfig conn
screens <- liftIO $ phiXScreenInfo xconfig disp panelWindows <- mapM (createPanelWindow conn config) screens
panelWindows <- mapM (createPanelWindow disp config) screens let dispvar = Widget.Display conn atoms
let dispvar = Widget.Display dispmvar atoms
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
screenPanels = zip screens panelWindows screenPanels = zip screens panelWindows
@ -116,29 +129,28 @@ runPhi xconfig config widget = do
, phiShutdownHold = 0 , phiShutdownHold = 0
, phiWidgetState = initialState , phiWidgetState = initialState
} $ do } $ do
updateRootImage disp updateRootImage conn xcb
Widget.withDisplay dispvar $ \disp -> do panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels
panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels
forM_ panels $ \panel -> do forM_ panels $ \panel -> do
setPanelProperties disp panel setPanelProperties conn panel
liftIO $ mapWindow disp (panelWindow panel) liftIO $ mapWindow conn (panelWindow panel)
modify $ \state -> state { phiPanels = panels } modify $ \state -> state { phiPanels = panels }
liftIO $ forkIO $ receiveEvents phi dispvar liftIO $ forkIO $ receiveEvents phi conn
forever $ do forever $ do
available <- messageAvailable phi available <- messageAvailable phi
unless available $ do unless available $ do
repaint <- gets phiRepaint repaint <- gets phiRepaint
when repaint $ do when repaint $ do
updatePanels dispvar updatePanels conn xcb
modify $ \state -> state {phiRepaint = False} modify $ \state -> state {phiRepaint = False}
message <- receiveMessage phi message <- receiveMessage phi
handleMessage dispvar message handleMessage conn xcb message
case (fromMessage message) of case (fromMessage message) of
Just Shutdown -> Just Shutdown ->
@ -163,8 +175,8 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown termHandler phi = Catch $ sendMessage phi Shutdown
handleMessage :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c () handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
handleMessage dispvar m = do handleMessage conn xcb m = do
w <- asks phiWidget w <- asks phiWidget
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m} modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
@ -173,34 +185,43 @@ handleMessage dispvar m = do
modify $ \state -> state {phiRepaint = True} modify $ \state -> state {phiRepaint = True}
_ -> _ ->
case (fromMessage m) of case (fromMessage m) of
Just event -> Just (XEvent event) ->
Widget.withDisplay dispvar $ flip handleEvent event handleEvent conn xcb event
_ -> _ ->
return () return ()
handleEvent :: (Widget w s c) => Display -> Event -> PhiX w s c () handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
handleEvent disp PropertyEvent { ev_atom = atom } = do handleEvent conn xcb event = do
case (fromEvent event) of
Just e -> handlePropertyNotifyEvent conn xcb e
Nothing -> case (fromEvent event) of
Just e -> handleConfigureNotifyEvent conn e
Nothing -> return ()
handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c ()
handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
phi <- asks phiPhi phi <- asks phiPhi
atoms <- asks phiAtoms atoms <- asks phiAtoms
panels <- gets phiPanels panels <- gets phiPanels
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
updateRootImage disp updateRootImage conn xcb
sendMessage phi ResetBackground sendMessage phi ResetBackground
sendMessage phi Repaint sendMessage phi Repaint
handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWindow disp = do handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c ()
handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do
phi <- asks phiPhi phi <- asks phiPhi
xconfig <- asks phiXConfig xconfig <- asks phiXConfig
config <- asks phiPanelConfig config <- asks phiPanelConfig
panels <- gets phiPanels panels <- gets phiPanels
let screens = map panelScreenArea panels let screens = map panelScreenArea panels
screens' <- liftIO $ phiXScreenInfo xconfig disp screens' <- liftIO $ phiXScreenInfo xconfig conn
when (screens /= screens') $ do when (screens /= screens') $ do
liftIO $ do liftIO $ do
mapM (freePixmap disp . panelPixmap) panels mapM_ (freePixmap conn . panelPixmap) panels
mapM_ (destroyWindow disp . panelWindow) $ drop (length screens') panels mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
@ -210,17 +231,21 @@ handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWi
let rect = panelBounds config screen let rect = panelBounds config screen
win = panelWindow panel win = panelWindow panel
liftIO $ withRectangle rect $ moveResizeWindow disp win liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect)
, (ConfigWindowY, fromIntegral $ y_RECTANGLE rect)
, (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect)
, (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect)
]
panel' <- createPanel disp win screen panel' <- createPanel conn win screen
setPanelProperties disp panel' setPanelProperties conn panel'
return panel' return panel'
Nothing -> do Nothing -> do
win <- liftIO $ createPanelWindow disp config screen win <- liftIO $ createPanelWindow conn config screen
panel <- createPanel disp win screen panel <- createPanel conn win screen
setPanelProperties disp panel setPanelProperties conn panel
liftIO $ mapWindow disp $ panelWindow panel liftIO $ mapWindow conn $ panelWindow panel
return panel return panel
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
@ -228,30 +253,13 @@ handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWi
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
sendMessage phi Repaint sendMessage phi Repaint
handleEvent _ _ = return ()
receiveEvents :: Phi -> Connection -> IO ()
receiveEvents phi conn = do
forever $ waitForEvent conn >>= sendMessage phi . XEvent
receiveEvents :: Phi -> Widget.Display -> IO () updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
receiveEvents phi dispvar = do updatePanels conn xcb = do
connection <- Widget.withDisplay dispvar $ return . Fd . connectionNumber
allocaXEvent $ \xevent -> forever $ do
handled <- Widget.withDisplay dispvar $ \disp -> do
pend <- pending disp
if pend /= 0 then
do
liftIO $ nextEvent disp xevent
event <- liftIO $ Util.getEvent disp xevent
sendMessage phi event
return True
else return False
--when (not handled) $ threadWaitRead connection
when (not handled) $ threadDelay 40000
updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c ()
updatePanels dispvar = do
w <- asks phiWidget w <- asks phiWidget
s <- gets phiWidgetState s <- gets phiWidgetState
rootImage <- gets phiRootImage rootImage <- gets phiRootImage
@ -264,16 +272,15 @@ updatePanels dispvar = do
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
(withDimension area $ Widget.render w s 0 0) (panelScreenArea panel) (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
Widget.withDisplay dispvar $ \disp -> do let screen = head . roots_Setup . connectionSetup $ conn
let screen = defaultScreen disp visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
visual = defaultVisual disp screen
xbuffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
renderWith buffer $ do renderWith buffer $ do
save save
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area))
withPatternForSurface rootImage $ \pattern -> do withPatternForSurface rootImage $ \pattern -> do
patternSetExtend pattern ExtendRepeat patternSetExtend pattern ExtendRepeat
setSource pattern setSource pattern
@ -294,30 +301,27 @@ updatePanels dispvar = do
surfaceFinish xbuffer surfaceFinish xbuffer
-- update window -- update window
liftIO $ do liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
(withDimension area $ clearArea disp (panelWindow panel) 0 0) True
sync disp False
return $ panel { panelWidgetCache = cache' } return $ panel { panelWidgetCache = cache' }
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
updateRootImage :: Display -> PhiX w s c () updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
updateRootImage disp = do updateRootImage conn xcb = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
let screen = defaultScreen disp let screen = head . roots_Setup . connectionSetup $ conn
visual = defaultVisual disp screen visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
rootwin = defaultRootWindow disp rootwin = root_SCREEN screen
pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
\atom -> liftIO $ getWindowProperty32 disp atom rootwin
(pixmapWidth, pixmapHeight) <- case pixmap of pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
\atom -> liftIO $ getProperty32 conn rootwin atom
(pixmapWidth, pixmapHeight) <- case (fromXid . toXid $ (pixmap :: PIXMAP) :: Word32) of
0 -> return (1, 1) 0 -> return (1, 1)
_ -> do _ -> liftIO $ getGeometry conn (fromXid . toXid $ pixmap) >>= getReply' "updateRootImage: getGeometry failed" >>= return . (width_GetGeometryReply &&& height_GetGeometryReply)
(_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
return (pixmapWidth, pixmapHeight)
-- update surface size -- update surface size
oldBg <- gets phiRootImage oldBg <- gets phiRootImage
@ -330,31 +334,33 @@ updateRootImage disp = do
bg <- gets phiRootImage bg <- gets phiRootImage
case pixmap of case (fromXid . toXid $ pixmap :: Word32) of
0 -> do 0 -> do
renderWith bg $ do renderWith bg $ do
setSourceRGB 0 0 0 setSourceRGB 0 0 0
paint paint
_ -> do _ -> do
rootSurface <- liftIO $ Util.createXlibSurface disp pixmap visual (fromIntegral pixmapWidth) (fromIntegral pixmapHeight) rootSurface <- liftIO $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight)
renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do
setSource pattern setSource pattern
paint paint
surfaceFinish rootSurface surfaceFinish rootSurface
return ()
createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c) createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
createPanel disp win screenRect = do createPanel conn win screenRect = do
config <- asks phiPanelConfig config <- asks phiPanelConfig
w <- asks phiWidget w <- asks phiWidget
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
screen = defaultScreen disp screen = head . roots_Setup . connectionSetup $ conn
depth = defaultDepth disp screen depth = root_depth_SCREEN screen
pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth pixmap <- liftIO $ newResource conn
liftIO $ setWindowBackgroundPixmap disp win pixmap liftIO $ createPixmap conn $ withDimension rect $ MkCreatePixmap depth pixmap (fromXid . toXid $ win)
liftIO $ changeWindowAttributes conn win $ toValueParam [(CWBackPixmap, fromXid . toXid $ pixmap)]
return PanelState { panelWindow = win return PanelState { panelWindow = win
, panelPixmap = pixmap , panelPixmap = pixmap
@ -363,74 +369,62 @@ createPanel disp win screenRect = do
, panelWidgetCache = initCache w , panelWidgetCache = initCache w
} }
createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
createPanelWindow disp config screenRect = do createPanelWindow conn config screenRect = do
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
screen = defaultScreen disp screen = head . roots_Setup . connectionSetup $ conn
depth = defaultDepth disp screen depth = root_depth_SCREEN screen
visual = defaultVisual disp screen rootwin = root_SCREEN screen
colormap = defaultColormap disp screen visual = root_visual_SCREEN screen
rootwin = defaultRootWindow disp win <- liftIO $ newResource conn
mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel createWindow conn $ (withRectangle rect $ MkCreateWindow depth win rootwin) 0 WindowClassInputOutput visual $
toValueParam [(CWEventMask, toMask [EventMaskExposure]), (CWBackPixel, 0), (CWBorderPixel, 0)]
allocaSetWindowAttributes $ \attr -> do return win
set_colormap attr colormap
set_background_pixel attr 0
set_border_pixel attr 0
set_event_mask attr exposureMask
withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
setPanelProperties :: Display -> PanelState w s c -> PhiX w s c () setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
setPanelProperties disp panel = do setPanelProperties conn panel = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
liftIO $ do liftIO $ do
storeName disp (panelWindow panel) "Phi" let name = map (fromIntegral . ord) "Phi"
changeProperty8 disp (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) propModeReplace $ map (fromIntegral . ord) "Phi" changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name
changeProperty8 conn PropModeReplace (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) name
changeProperty32 disp (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) aTOM propModeReplace [fromIntegral (atom_NET_WM_WINDOW_TYPE_DOCK atoms)] changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) (atomATOM atoms) [fromXid . toXid $ atom_NET_WM_WINDOW_TYPE_DOCK atoms]
changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF] changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_DESKTOP atoms) (atomCARDINAL atoms) [0xFFFFFFFF]
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms) changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STATE atoms) (atomATOM atoms) $
, fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms) map (fromXid . toXid) [ atom_NET_WM_STATE_SKIP_PAGER atoms
, fromIntegral (atom_NET_WM_STATE_STICKY atoms) , atom_NET_WM_STATE_SKIP_TASKBAR atoms
, fromIntegral (atom_NET_WM_STATE_BELOW atoms) , atom_NET_WM_STATE_STICKY atoms
, atom_NET_WM_STATE_BELOW atoms
] ]
setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit
, wmh_input = False
, wmh_initial_state = 0
, wmh_icon_pixmap = 0
, wmh_icon_window = 0
, wmh_icon_x = 0
, wmh_icon_y = 0
, wmh_icon_mask = 0
, 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" } changeProperty32 conn PropModeReplace (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) [ 2, 0, 0, 0, 0 ]
setStruts disp panel changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi"
setStruts conn panel
setStruts :: Display -> PanelState w s c -> PhiX w s c () setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
setStruts disp panel = do setStruts conn panel = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
config <- asks phiPanelConfig config <- asks phiPanelConfig
let rootwin = defaultRootWindow disp let rootwin = getRoot conn
position = Panel.panelPosition config position = Panel.panelPosition config
area = panelArea panel area = panelArea panel
(_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply
let struts = [makeStruts i | i <- [0..11]] let struts = [makeStruts i | i <- [0..11]]
where where
makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area) makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
makeTopStruts 8 = (fromIntegral $ rect_x area) makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
makeTopStruts _ = 0 makeTopStruts _ = 0
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area) makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
makeBottomStruts 10 = (fromIntegral $ rect_x area) makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
makeBottomStruts _ = 0 makeBottomStruts _ = 0
makeStruts = case position of makeStruts = case position of
@ -438,21 +432,21 @@ setStruts disp panel = do
Phi.Bottom -> makeBottomStruts Phi.Bottom -> makeBottomStruts
liftIO $ do liftIO $ do
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT atoms) (atomCARDINAL atoms) $ take 4 struts
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) cARDINAL propModeReplace struts changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts
panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE
panelBounds config screenBounds = case Panel.panelPosition config of panelBounds config screenBounds = case Panel.panelPosition config of
Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config } Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config, Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config,
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) } y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) }
withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a
withRectangle r = withDimension r . withPosition r withRectangle r = withDimension r . withPosition r
withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r) withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r) withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)

14
lib/Phi/X11/AtomList.hs
View file

@ -6,10 +6,16 @@ module Phi.X11.AtomList ( atoms
import Language.Haskell.TH import Language.Haskell.TH
import Graphics.X11.Xlib import Graphics.XHB
import Graphics.XHB.Connection.Open
atoms :: [String] atoms :: [String]
atoms = [ "UTF8_STRING" atoms = [ "ATOM"
, "CARDINAL"
, "STRING"
, "UTF8_STRING"
, "WM_NAME"
, "WM_CLASS"
, "MANAGER" , "MANAGER"
, "_NET_WM_NAME" , "_NET_WM_NAME"
, "_NET_WM_WINDOW_TYPE" , "_NET_WM_WINDOW_TYPE"
@ -43,7 +49,7 @@ atoms = [ "UTF8_STRING"
, "_XROOTMAP_ID" , "_XROOTMAP_ID"
] ]
-- the expression must have the type (Display -> String) -- the expression must have the type (Connection -> String)
specialAtoms :: [(String, Q Exp)] specialAtoms :: [(String, Q Exp)]
specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|]) specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|])
] ]

30
lib/Phi/X11/Atoms.hs
View file

@ -5,36 +5,48 @@ module Phi.X11.Atoms ( Atoms(..)
) where ) where
import Control.Monad import Control.Monad
import Data.Char
import Data.List
import Language.Haskell.TH import Language.Haskell.TH
import Graphics.X11 import Graphics.XHB
import Graphics.XHB.Gen.Xproto
import Phi.X11.AtomList import Phi.X11.AtomList
$(let atomsName = mkName "Atoms" $(let atomsName = mkName "Atoms"
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms) atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames fields = map (\(_, name) -> (name, IsStrict, ConT ''ATOM)) atomNames
in return [DataD [] atomsName [] [RecC atomsName fields] []] in return [DataD [] atomsName [] [RecC atomsName fields] []]
) )
initAtoms :: Display -> IO Atoms initAtoms :: Connection -> IO Atoms
initAtoms display = initAtoms conn =
$(do $(do
normalAtomNames <- mapM (\atom -> do normalAtomNames <- mapM (\atom -> do
receiptName <- newName ('_':atom)
varName <- newName ('_':atom) varName <- newName ('_':atom)
return ([|const atom|], mkName ("atom" ++ atom), varName) return ([|const atom|], mkName ("atom" ++ atom), receiptName, varName)
) atoms ) atoms
specialAtomNames <- mapM (\(name, atomgen) -> do specialAtomNames <- mapM (\(name, atomgen) -> do
receiptName <- newName ('_':name)
varName <- newName ('_':name) varName <- newName ('_':name)
return (atomgen, mkName ("atom" ++ name), varName) return (atomgen, mkName ("atom" ++ name), receiptName, varName)
) specialAtoms ) specialAtoms
let atomNames = normalAtomNames ++ specialAtomNames let atomNames = normalAtomNames ++ specialAtomNames
atomReceipts <- forM atomNames $
\(atomgen, _, receiptName, _) -> liftM (BindS (VarP receiptName))
[|let name = ($atomgen conn)
in internAtom conn $ MkInternAtom False (genericLength name) $ map (fromIntegral . ord) name|]
atomInitializers <- forM atomNames $ atomInitializers <- forM atomNames $
\(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |] \(_, _, receiptName, varName) -> liftM (BindS (VarP varName))
[|liftM (\(Right a) -> a) $ getReply $(return $ VarE receiptName)|]
let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
let atomFieldExps = map (\(_, atomName, _, varName) -> (atomName, VarE varName)) atomNames
atomsName = mkName "Atoms" atomsName = mkName "Atoms"
atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
return $ DoE $ atomInitializers ++ [atomsContruction] return $ DoE $ atomReceipts ++ atomInitializers ++ [atomsContruction]
) )

89
lib/Phi/X11/Util.hs Normal file
View file

@ -0,0 +1,89 @@
module Phi.X11.Util ( getReply'
, changeProperty8
, changeProperty16
, changeProperty32
, getProperty8
, getProperty16
, getProperty32
, findVisualtype
) where
import Control.Monad
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.XHB
import Graphics.XHB.Gen.Xproto
import System.IO.Unsafe
getReply' :: String -> Receipt a -> IO a
getReply' m = getReply >=> return . fromRight
where
fromRight (Left _) = error m
fromRight (Right a) = a
castWord16to8 :: [Word16] -> [Word8]
castWord16to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (2 * length input) (castPtr ptr)
castWord32to8 :: [Word32] -> [Word8]
castWord32to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (4 * length input) (castPtr ptr)
castWord8to16 :: [Word8] -> [Word16]
castWord8to16 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 2) (castPtr ptr)
castWord8to32 :: [Word8] -> [Word32]
castWord8to32 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 4) (castPtr ptr)
changeProperty8 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata
changeProperty16 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata)
changeProperty32 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata)
getProperty' :: Word8 -> Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty' format conn win prop = do
reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply
case reply of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = 0, value_GetPropertyReply = value}) -> return $ Just value
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = bytes_after}) -> do
reply' <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 (4+bytes_after)) >>= getReply
case reply' of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value
getProperty8 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty8 = getProperty' 8
getProperty16 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word16])
getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
getProperty32 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word32])
getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32
findVisualtype :: SCREEN -> VISUALID -> Maybe VISUALTYPE
findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen

13
phi.cabal
View file

@ -11,15 +11,16 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple build-type: Simple
library library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, data-accessor, arrows, CacheArrow build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11, cairo, pango, unix, data-accessor, arrows, CacheArrow
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler Phi.Widgets.AlphaBox, Phi.Widgets.Clock
c-sources: csrc/SystrayErrorHandler.c -- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
include-dirs: include include-dirs: include
hs-source-dirs: lib hs-source-dirs: lib
extra-libraries: X11 extra-libraries: X11
pkgconfig-depends: cairo >= 1.2.0, cairo-xlib pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb
ghc-options: -fspec-constr-count=16 -threaded ghc-options: -fspec-constr-count=16 -threaded
executable Phi executable Phi

10
src/Phi.hs
View file

@ -6,13 +6,13 @@ import Phi.X11
import Phi.Widgets.AlphaBox import Phi.Widgets.AlphaBox
import Phi.Widgets.Clock import Phi.Widgets.Clock
import Phi.Widgets.Taskbar --import Phi.Widgets.Taskbar
import Phi.Widgets.Systray --import Phi.Widgets.Systray
main :: IO () main :: IO ()
main = do main = do
runPhi defaultXConfig defaultPanelConfig { panelPosition = Top } $ alphaBox 0.9 $ theTaskbar <~> brightBorder theSystray <~> brightBorder theClock runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } $ alphaBox 0.9 $ {- theTaskbar <~> brightBorder theSystray <~> -} brightBorder theClock
where where
normalTaskBorder = BorderConfig (BorderWidth (-1) (-3) (-1) 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 0.8) 5 0 normalTaskBorder = BorderConfig (BorderWidth (-1) (-3) (-1) 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 0.8) 5 0
activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8) activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
@ -25,7 +25,7 @@ main = do
} }
currentDesktopBorder = normalDesktopBorder { backgroundColor = (0.2, 0.2, 0.2, 0.9) currentDesktopBorder = normalDesktopBorder { backgroundColor = (0.2, 0.2, 0.2, 0.9)
} }
taskStyle = TaskStyle { taskFont = "Sans 7" {-taskStyle = TaskStyle { taskFont = "Sans 7"
, taskColor = (1, 1, 1, 1) , taskColor = (1, 1, 1, 1)
, taskBorder = normalTaskBorder , taskBorder = normalTaskBorder
, taskIconStyle = idIconStyle , taskIconStyle = idIconStyle
@ -46,7 +46,7 @@ main = do
, desktopStyle = Just (normalDesktopStyle, currentDesktopStyle) , desktopStyle = Just (normalDesktopStyle, currentDesktopStyle)
} }
theSystray = systray theSystray = systray-}
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>" theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
, lineSpacing = (-3) , lineSpacing = (-3)