Converted core to XHB/XCB
This commit is contained in:
parent
42d5f27d32
commit
15d9304e05
11 changed files with 433 additions and 368 deletions
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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
92
lib/Phi/Bindings/XCB.hsc
Normal 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
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
|
||||
|
||||
module Phi.Widget ( Display(..)
|
||||
module Phi.Widget ( XEvent(..)
|
||||
, Display(..)
|
||||
, withDisplay
|
||||
, getAtoms
|
||||
, XMessage(..)
|
||||
|
|
@ -30,36 +31,38 @@ import Control.Monad.IO.Class
|
|||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
|
||||
import qualified Graphics.X11.Xlib as Xlib
|
||||
import Graphics.XHB
|
||||
import Graphics.Rendering.Cairo
|
||||
|
||||
import Phi.Phi
|
||||
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
|
||||
withDisplay (Display dispvar _) f = do
|
||||
disp <- liftIO $ takeMVar dispvar
|
||||
a <- f disp
|
||||
liftIO $ putMVar dispvar disp
|
||||
return a
|
||||
newtype XEvent = XEvent SomeEvent deriving Typeable
|
||||
|
||||
instance Show XEvent where
|
||||
show _ = "XEvent (..)"
|
||||
|
||||
|
||||
withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
|
||||
withDisplay (Display conn _) f = f conn
|
||||
|
||||
getAtoms :: Display -> 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
|
||||
where
|
||||
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
||||
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
||||
|
||||
Xlib.Rectangle ax1 ay1 aw ah = a
|
||||
Xlib.Rectangle bx1 by1 bw bh = b
|
||||
MkRECTANGLE ax1 ay1 aw ah = a
|
||||
MkRECTANGLE bx1 by1 bw bh = b
|
||||
|
||||
ax2 = ax1 + fromIntegral aw
|
||||
ay2 = ay1 + fromIntegral ah
|
||||
|
|
@ -71,22 +74,24 @@ unionArea a b = fromIntegral $ uw*uh
|
|||
data SurfaceSlice = SurfaceSlice !Int !Surface
|
||||
|
||||
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
|
||||
|
||||
minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
|
||||
minSize :: w -> s -> Int -> RECTANGLE -> Int
|
||||
|
||||
weight :: w -> Float
|
||||
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 _ priv _ = priv
|
||||
|
||||
deriving instance Eq RECTANGLE
|
||||
|
||||
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 = lift . Kleisli
|
||||
|
|
@ -98,8 +103,8 @@ runIOCache a = do
|
|||
put cache'
|
||||
return b
|
||||
|
||||
createRenderCache :: (s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
|
||||
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
||||
createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
|
||||
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface
|
||||
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
|
||||
surface <- createImageSurface FormatARGB32 w h
|
||||
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
|
||||
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
|
||||
cache <- get
|
||||
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)
|
||||
|
|
|
|||
300
lib/Phi/X11.hs
300
lib/Phi/X11.hs
|
|
@ -5,16 +5,19 @@ module Phi.X11 ( XConfig(..)
|
|||
, runPhi
|
||||
) where
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Graphics.X11.Xinerama
|
||||
import Graphics.XHB
|
||||
import Graphics.XHB.Gen.Xinerama
|
||||
import Graphics.XHB.Gen.Xproto
|
||||
|
||||
import Graphics.Rendering.Cairo
|
||||
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import Data.Bits
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
import Data.Word
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Concurrent
|
||||
|
|
@ -27,16 +30,18 @@ import System.Exit
|
|||
import System.Posix.Signals
|
||||
import System.Posix.Types
|
||||
|
||||
import qualified Phi.Bindings.XCB as XCB
|
||||
|
||||
import Phi.Phi
|
||||
import Phi.X11.Util
|
||||
import qualified Phi.Types as Phi
|
||||
import qualified Phi.Panel as Panel
|
||||
import qualified Phi.Widget as Widget
|
||||
import Phi.Widget hiding (Display, handleMessage)
|
||||
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
|
||||
|
|
@ -47,10 +52,10 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su
|
|||
, phiWidgetState :: !s
|
||||
}
|
||||
|
||||
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window
|
||||
, panelPixmap :: !Pixmap
|
||||
, panelArea :: !Rectangle
|
||||
, panelScreenArea :: !Rectangle
|
||||
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW
|
||||
, panelPixmap :: !PIXMAP
|
||||
, panelArea :: !RECTANGLE
|
||||
, panelScreenArea :: !RECTANGLE
|
||||
, panelWidgetCache :: !c
|
||||
}
|
||||
|
||||
|
|
@ -76,27 +81,35 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
|
|||
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 xconfig config widget = do
|
||||
xSetErrorHandler
|
||||
|
||||
phi <- initPhi
|
||||
|
||||
installHandler sigTERM (termHandler phi) Nothing
|
||||
installHandler sigINT (termHandler phi) Nothing
|
||||
installHandler sigQUIT (termHandler phi) Nothing
|
||||
|
||||
disp <- openDisplay []
|
||||
conn <- liftM fromJust connect
|
||||
xcb <- XCB.connect
|
||||
|
||||
atoms <- initAtoms disp
|
||||
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
|
||||
atoms <- initAtoms conn
|
||||
changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
|
||||
|
||||
bg <- createImageSurface FormatRGB24 1 1
|
||||
|
||||
dispmvar <- newMVar disp
|
||||
screens <- liftIO $ phiXScreenInfo xconfig disp
|
||||
panelWindows <- mapM (createPanelWindow disp config) screens
|
||||
let dispvar = Widget.Display dispmvar atoms
|
||||
screens <- liftIO $ phiXScreenInfo xconfig conn
|
||||
panelWindows <- mapM (createPanelWindow conn config) screens
|
||||
let dispvar = Widget.Display conn atoms
|
||||
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
|
||||
screenPanels = zip screens panelWindows
|
||||
|
||||
|
|
@ -116,29 +129,28 @@ runPhi xconfig config widget = do
|
|||
, phiShutdownHold = 0
|
||||
, phiWidgetState = initialState
|
||||
} $ do
|
||||
updateRootImage disp
|
||||
updateRootImage conn xcb
|
||||
|
||||
Widget.withDisplay dispvar $ \disp -> do
|
||||
panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels
|
||||
panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels
|
||||
|
||||
forM_ panels $ \panel -> do
|
||||
setPanelProperties disp panel
|
||||
liftIO $ mapWindow disp (panelWindow panel)
|
||||
setPanelProperties conn panel
|
||||
liftIO $ mapWindow conn (panelWindow panel)
|
||||
|
||||
modify $ \state -> state { phiPanels = panels }
|
||||
|
||||
liftIO $ forkIO $ receiveEvents phi dispvar
|
||||
liftIO $ forkIO $ receiveEvents phi conn
|
||||
|
||||
forever $ do
|
||||
available <- messageAvailable phi
|
||||
unless available $ do
|
||||
repaint <- gets phiRepaint
|
||||
when repaint $ do
|
||||
updatePanels dispvar
|
||||
updatePanels conn xcb
|
||||
modify $ \state -> state {phiRepaint = False}
|
||||
|
||||
message <- receiveMessage phi
|
||||
handleMessage dispvar message
|
||||
handleMessage conn xcb message
|
||||
|
||||
case (fromMessage message) of
|
||||
Just Shutdown ->
|
||||
|
|
@ -163,8 +175,8 @@ termHandler :: Phi -> Handler
|
|||
termHandler phi = Catch $ sendMessage phi Shutdown
|
||||
|
||||
|
||||
handleMessage :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c ()
|
||||
handleMessage dispvar m = do
|
||||
handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
|
||||
handleMessage conn xcb m = do
|
||||
w <- asks phiWidget
|
||||
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
|
||||
|
||||
|
|
@ -173,34 +185,43 @@ handleMessage dispvar m = do
|
|||
modify $ \state -> state {phiRepaint = True}
|
||||
_ ->
|
||||
case (fromMessage m) of
|
||||
Just event ->
|
||||
Widget.withDisplay dispvar $ flip handleEvent event
|
||||
Just (XEvent event) ->
|
||||
handleEvent conn xcb event
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
handleEvent :: (Widget w s c) => Display -> Event -> PhiX w s c ()
|
||||
handleEvent disp PropertyEvent { ev_atom = atom } = do
|
||||
handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
|
||||
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
|
||||
atoms <- asks phiAtoms
|
||||
panels <- gets phiPanels
|
||||
|
||||
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
|
||||
updateRootImage disp
|
||||
updateRootImage conn xcb
|
||||
sendMessage phi ResetBackground
|
||||
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
|
||||
xconfig <- asks phiXConfig
|
||||
config <- asks phiPanelConfig
|
||||
panels <- gets phiPanels
|
||||
let screens = map panelScreenArea panels
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig disp
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig conn
|
||||
|
||||
when (screens /= screens') $ do
|
||||
liftIO $ do
|
||||
mapM (freePixmap disp . panelPixmap) panels
|
||||
mapM_ (destroyWindow disp . panelWindow) $ drop (length screens') panels
|
||||
mapM_ (freePixmap conn . panelPixmap) panels
|
||||
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
|
||||
|
||||
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
|
||||
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
|
||||
setPanelProperties disp panel'
|
||||
panel' <- createPanel conn win screen
|
||||
setPanelProperties conn panel'
|
||||
|
||||
return panel'
|
||||
Nothing -> do
|
||||
win <- liftIO $ createPanelWindow disp config screen
|
||||
panel <- createPanel disp win screen
|
||||
setPanelProperties disp panel
|
||||
liftIO $ mapWindow disp $ panelWindow panel
|
||||
win <- liftIO $ createPanelWindow conn config screen
|
||||
panel <- createPanel conn win screen
|
||||
setPanelProperties conn panel
|
||||
liftIO $ mapWindow conn $ panelWindow panel
|
||||
return panel
|
||||
|
||||
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 Repaint
|
||||
|
||||
handleEvent _ _ = return ()
|
||||
|
||||
receiveEvents :: Phi -> Connection -> IO ()
|
||||
receiveEvents phi conn = do
|
||||
forever $ waitForEvent conn >>= sendMessage phi . XEvent
|
||||
|
||||
receiveEvents :: Phi -> Widget.Display -> IO ()
|
||||
receiveEvents phi dispvar = 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
|
||||
updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updatePanels conn xcb = do
|
||||
w <- asks phiWidget
|
||||
s <- gets phiWidgetState
|
||||
rootImage <- gets phiRootImage
|
||||
|
|
@ -264,16 +272,15 @@ updatePanels dispvar = do
|
|||
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
|
||||
(withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
|
||||
|
||||
Widget.withDisplay dispvar $ \disp -> do
|
||||
let screen = defaultScreen disp
|
||||
visual = defaultVisual disp screen
|
||||
let screen = head . roots_Setup . connectionSetup $ conn
|
||||
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN 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
|
||||
renderWith buffer $ do
|
||||
save
|
||||
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
|
||||
translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area))
|
||||
withPatternForSurface rootImage $ \pattern -> do
|
||||
patternSetExtend pattern ExtendRepeat
|
||||
setSource pattern
|
||||
|
|
@ -294,30 +301,27 @@ updatePanels dispvar = do
|
|||
surfaceFinish xbuffer
|
||||
|
||||
-- update window
|
||||
liftIO $ do
|
||||
(withDimension area $ clearArea disp (panelWindow panel) 0 0) True
|
||||
sync disp False
|
||||
liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
|
||||
|
||||
return $ panel { panelWidgetCache = cache' }
|
||||
|
||||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
|
||||
updateRootImage :: Display -> PhiX w s c ()
|
||||
updateRootImage disp = do
|
||||
updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updateRootImage conn xcb = do
|
||||
atoms <- asks phiAtoms
|
||||
|
||||
let screen = defaultScreen disp
|
||||
visual = defaultVisual disp screen
|
||||
rootwin = defaultRootWindow disp
|
||||
pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
|
||||
\atom -> liftIO $ getWindowProperty32 disp atom rootwin
|
||||
let screen = head . roots_Setup . connectionSetup $ conn
|
||||
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
|
||||
rootwin = root_SCREEN screen
|
||||
|
||||
(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)
|
||||
_ -> do
|
||||
(_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
|
||||
return (pixmapWidth, pixmapHeight)
|
||||
_ -> liftIO $ getGeometry conn (fromXid . toXid $ pixmap) >>= getReply' "updateRootImage: getGeometry failed" >>= return . (width_GetGeometryReply &&& height_GetGeometryReply)
|
||||
|
||||
-- update surface size
|
||||
oldBg <- gets phiRootImage
|
||||
|
|
@ -330,31 +334,33 @@ updateRootImage disp = do
|
|||
|
||||
bg <- gets phiRootImage
|
||||
|
||||
case pixmap of
|
||||
case (fromXid . toXid $ pixmap :: Word32) of
|
||||
0 -> do
|
||||
renderWith bg $ do
|
||||
setSourceRGB 0 0 0
|
||||
paint
|
||||
_ -> 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
|
||||
setSource pattern
|
||||
paint
|
||||
|
||||
surfaceFinish rootSurface
|
||||
return ()
|
||||
|
||||
|
||||
createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c)
|
||||
createPanel disp win screenRect = do
|
||||
createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
|
||||
createPanel conn win screenRect = do
|
||||
config <- asks phiPanelConfig
|
||||
w <- asks phiWidget
|
||||
let rect = panelBounds config screenRect
|
||||
screen = defaultScreen disp
|
||||
depth = defaultDepth disp screen
|
||||
screen = head . roots_Setup . connectionSetup $ conn
|
||||
depth = root_depth_SCREEN screen
|
||||
|
||||
pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
|
||||
liftIO $ setWindowBackgroundPixmap disp win pixmap
|
||||
pixmap <- liftIO $ newResource conn
|
||||
liftIO $ createPixmap conn $ withDimension rect $ MkCreatePixmap depth pixmap (fromXid . toXid $ win)
|
||||
liftIO $ changeWindowAttributes conn win $ toValueParam [(CWBackPixmap, fromXid . toXid $ pixmap)]
|
||||
|
||||
return PanelState { panelWindow = win
|
||||
, panelPixmap = pixmap
|
||||
|
|
@ -363,74 +369,62 @@ createPanel disp win screenRect = do
|
|||
, panelWidgetCache = initCache w
|
||||
}
|
||||
|
||||
createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window
|
||||
createPanelWindow disp config screenRect = do
|
||||
createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
|
||||
createPanelWindow conn config screenRect = do
|
||||
let rect = panelBounds config screenRect
|
||||
screen = defaultScreen disp
|
||||
depth = defaultDepth disp screen
|
||||
visual = defaultVisual disp screen
|
||||
colormap = defaultColormap disp screen
|
||||
rootwin = defaultRootWindow disp
|
||||
mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel
|
||||
|
||||
allocaSetWindowAttributes $ \attr -> do
|
||||
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
|
||||
screen = head . roots_Setup . connectionSetup $ conn
|
||||
depth = root_depth_SCREEN screen
|
||||
rootwin = root_SCREEN screen
|
||||
visual = root_visual_SCREEN screen
|
||||
win <- liftIO $ newResource conn
|
||||
createWindow conn $ (withRectangle rect $ MkCreateWindow depth win rootwin) 0 WindowClassInputOutput visual $
|
||||
toValueParam [(CWEventMask, toMask [EventMaskExposure]), (CWBackPixel, 0), (CWBorderPixel, 0)]
|
||||
return win
|
||||
|
||||
|
||||
setPanelProperties :: Display -> PanelState w s c -> PhiX w s c ()
|
||||
setPanelProperties disp panel = do
|
||||
setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setPanelProperties conn panel = do
|
||||
atoms <- asks phiAtoms
|
||||
liftIO $ do
|
||||
storeName disp (panelWindow panel) "Phi"
|
||||
changeProperty8 disp (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) propModeReplace $ map (fromIntegral . ord) "Phi"
|
||||
let name = 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 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF]
|
||||
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms)
|
||||
, fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms)
|
||||
, fromIntegral (atom_NET_WM_STATE_STICKY atoms)
|
||||
, fromIntegral (atom_NET_WM_STATE_BELOW atoms)
|
||||
changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) (atomATOM atoms) [fromXid . toXid $ atom_NET_WM_WINDOW_TYPE_DOCK atoms]
|
||||
changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_DESKTOP atoms) (atomCARDINAL atoms) [0xFFFFFFFF]
|
||||
changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STATE atoms) (atomATOM atoms) $
|
||||
map (fromXid . toXid) [ atom_NET_WM_STATE_SKIP_PAGER atoms
|
||||
, atom_NET_WM_STATE_SKIP_TASKBAR 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 disp panel = do
|
||||
setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setStruts conn panel = do
|
||||
atoms <- asks phiAtoms
|
||||
config <- asks phiPanelConfig
|
||||
let rootwin = defaultRootWindow disp
|
||||
let rootwin = getRoot conn
|
||||
position = Panel.panelPosition config
|
||||
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]]
|
||||
where
|
||||
makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
|
||||
makeTopStruts 8 = (fromIntegral $ rect_x area)
|
||||
makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
|
||||
makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
|
||||
makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
|
||||
makeTopStruts _ = 0
|
||||
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
|
||||
makeBottomStruts 10 = (fromIntegral $ rect_x area)
|
||||
makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
|
||||
makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
|
||||
makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
|
||||
makeBottomStruts _ = 0
|
||||
|
||||
makeStruts = case position of
|
||||
|
|
@ -438,21 +432,21 @@ setStruts disp panel = do
|
|||
Phi.Bottom -> makeBottomStruts
|
||||
|
||||
liftIO $ do
|
||||
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ 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 atoms) (atomCARDINAL atoms) $ take 4 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
|
||||
Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
|
||||
Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
|
||||
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
|
||||
Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
|
||||
Phi.Bottom -> screenBounds { height_RECTANGLE = 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
|
||||
|
||||
withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a
|
||||
withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
|
||||
withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
|
||||
withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
|
||||
|
||||
withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
|
||||
withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)
|
||||
|
|
|
|||
|
|
@ -6,10 +6,16 @@ module Phi.X11.AtomList ( atoms
|
|||
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.XHB
|
||||
import Graphics.XHB.Connection.Open
|
||||
|
||||
atoms :: [String]
|
||||
atoms = [ "UTF8_STRING"
|
||||
atoms = [ "ATOM"
|
||||
, "CARDINAL"
|
||||
, "STRING"
|
||||
, "UTF8_STRING"
|
||||
, "WM_NAME"
|
||||
, "WM_CLASS"
|
||||
, "MANAGER"
|
||||
, "_NET_WM_NAME"
|
||||
, "_NET_WM_WINDOW_TYPE"
|
||||
|
|
@ -43,7 +49,7 @@ atoms = [ "UTF8_STRING"
|
|||
, "_XROOTMAP_ID"
|
||||
]
|
||||
|
||||
-- the expression must have the type (Display -> String)
|
||||
-- the expression must have the type (Connection -> String)
|
||||
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|])
|
||||
]
|
||||
|
|
@ -5,36 +5,48 @@ module Phi.X11.Atoms ( Atoms(..)
|
|||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Char
|
||||
import Data.List
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Graphics.X11
|
||||
import Graphics.XHB
|
||||
import Graphics.XHB.Gen.Xproto
|
||||
|
||||
import Phi.X11.AtomList
|
||||
|
||||
|
||||
$(let atomsName = mkName "Atoms"
|
||||
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] []]
|
||||
)
|
||||
|
||||
initAtoms :: Display -> IO Atoms
|
||||
initAtoms display =
|
||||
initAtoms :: Connection -> IO Atoms
|
||||
initAtoms conn =
|
||||
$(do
|
||||
normalAtomNames <- mapM (\atom -> do
|
||||
receiptName <- newName ('_':atom)
|
||||
varName <- newName ('_':atom)
|
||||
return ([|const atom|], mkName ("atom" ++ atom), varName)
|
||||
return ([|const atom|], mkName ("atom" ++ atom), receiptName, varName)
|
||||
) atoms
|
||||
specialAtomNames <- mapM (\(name, atomgen) -> do
|
||||
receiptName <- newName ('_':name)
|
||||
varName <- newName ('_':name)
|
||||
return (atomgen, mkName ("atom" ++ name), varName)
|
||||
return (atomgen, mkName ("atom" ++ name), receiptName, varName)
|
||||
) specialAtoms
|
||||
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 $
|
||||
\(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"
|
||||
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
89
lib/Phi/X11/Util.hs
Normal 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
13
phi.cabal
|
|
@ -11,15 +11,16 @@ maintainer: mschiffer@universe-factory.net
|
|||
build-type: Simple
|
||||
|
||||
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
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
|
||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler
|
||||
c-sources: csrc/SystrayErrorHandler.c
|
||||
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
|
||||
cairo, pango, unix, data-accessor, arrows, CacheArrow
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
|
||||
Phi.Widgets.AlphaBox, Phi.Widgets.Clock
|
||||
-- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
|
||||
other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
|
||||
include-dirs: include
|
||||
hs-source-dirs: lib
|
||||
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
|
||||
|
||||
executable Phi
|
||||
|
|
|
|||
10
src/Phi.hs
10
src/Phi.hs
|
|
@ -6,13 +6,13 @@ import Phi.X11
|
|||
|
||||
import Phi.Widgets.AlphaBox
|
||||
import Phi.Widgets.Clock
|
||||
import Phi.Widgets.Taskbar
|
||||
import Phi.Widgets.Systray
|
||||
--import Phi.Widgets.Taskbar
|
||||
--import Phi.Widgets.Systray
|
||||
|
||||
|
||||
main :: IO ()
|
||||
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
|
||||
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)
|
||||
|
|
@ -25,7 +25,7 @@ main = do
|
|||
}
|
||||
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)
|
||||
, taskBorder = normalTaskBorder
|
||||
, taskIconStyle = idIconStyle
|
||||
|
|
@ -46,7 +46,7 @@ main = do
|
|||
, 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>"
|
||||
, lineSpacing = (-3)
|
||||
|
|
|
|||
Reference in a new issue