----------------------------------------------------------------------------- -- | -- Module : -- Copyright : (c) Spencer Janssen -- License : BSD3-style (see LICENSE) -- -- Stability : stable -- ----------------------------------------------------------------------------- -- -- missing functionality from the X11 library -- module Graphics.X11.Xlib.Extras where import Graphics.X11.Xlib import Graphics.X11.Xlib.Types import Graphics.X11.Xlib.Misc import Foreign import Foreign.C.Types import Foreign.C.String import Control.Monad #include "XlibExtras.h" data Event = AnyEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_window :: !Window } | ConfigureRequestEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_parent :: !Window , ev_window :: !Window , ev_x :: !CInt , ev_y :: !CInt , ev_width :: !CInt , ev_height :: !CInt , ev_border_width :: !CInt , ev_above :: !Window , ev_detail :: !NotifyDetail , ev_value_mask :: !CULong } | ConfigureEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_event :: !Window , ev_window :: !Window , ev_x :: !CInt , ev_y :: !CInt , ev_width :: !CInt , ev_height :: !CInt , ev_border_width :: !CInt , ev_above :: !Window , ev_override_redirect :: !Bool } | MapRequestEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_parent :: !Window , ev_window :: !Window } | KeyEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_window :: !Window , ev_root :: !Window , ev_subwindow :: !Window , ev_time :: !Time , ev_x :: !CInt , ev_y :: !CInt , ev_x_root :: !CInt , ev_y_root :: !CInt , ev_state :: !KeyMask , ev_keycode :: !KeyCode , ev_same_screen :: !Bool } | ButtonEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_window :: !Window , ev_root :: !Window , ev_subwindow :: !Window , ev_time :: !Time , ev_x :: !CInt , ev_y :: !CInt , ev_x_root :: !CInt , ev_y_root :: !CInt , ev_state :: !KeyMask , ev_button :: !Button , ev_same_screen :: !Bool } | DestroyWindowEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_event :: !Window , ev_window :: !Window } | UnmapEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_event :: !Window , ev_window :: !Window , ev_from_configure :: !Bool } | MapNotifyEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_event :: !Window , ev_window :: !Window , ev_override_redirect :: !Bool } | MappingNotifyEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_window :: !Window , ev_request :: !MappingRequest , ev_first_keycode :: !KeyCode , ev_count :: !CInt } | CrossingEvent { ev_event_type :: !EventType , ev_serial :: !CULong , ev_send_event :: !Bool , ev_event_display :: Display , ev_window :: !Window , ev_root :: !Window , ev_subwindow :: !Window , ev_time :: !Time , ev_x :: !CInt , ev_y :: !CInt , ev_x_root :: !CInt , ev_y_root :: !CInt , ev_mode :: !NotifyMode , ev_detail :: !NotifyDetail , ev_same_screen :: !Bool , ev_focus :: !Bool , ev_state :: !Modifier } deriving Show eventTable = [ (keyPress , "KeyPress") , (keyRelease , "KeyRelease") , (buttonPress , "ButtonPress") , (buttonRelease , "ButtonRelease") , (motionNotify , "MotionNotify") , (enterNotify , "EnterNotify") , (leaveNotify , "LeaveNotify") , (focusIn , "FocusIn") , (focusOut , "FocusOut") , (keymapNotify , "KeymapNotify") , (expose , "Expose") , (graphicsExpose , "GraphicsExpose") , (noExpose , "NoExpose") , (visibilityNotify , "VisibilityNotify") , (createNotify , "CreateNotify") , (destroyNotify , "DestroyNotify") , (unmapNotify , "UnmapNotify") , (mapNotify , "MapNotify") , (mapRequest , "MapRequest") , (reparentNotify , "ReparentNotify") , (configureNotify , "ConfigureNotify") , (configureRequest , "ConfigureRequest") , (gravityNotify , "GravityNotify") , (resizeRequest , "ResizeRequest") , (circulateNotify , "CirculateNotify") , (circulateRequest , "CirculateRequest") , (propertyNotify , "PropertyNotify") , (selectionClear , "SelectionClear") , (selectionRequest , "SelectionRequest") , (selectionNotify , "SelectionNotify") , (colormapNotify , "ColormapNotify") , (clientMessage , "ClientMessage") , (mappingNotify , "MappingNotify") , (lASTEvent , "LASTEvent") ] eventName :: Event -> String eventName e = maybe ("unknown " ++ show x) id $ lookup x eventTable where x = fromIntegral $ ev_event_type e getEvent :: XEventPtr -> IO Event getEvent p = do -- All events share this layout and naming convention, there is also a -- common Window field, but the names for this field vary. type_ <- #{peek XAnyEvent, type} p serial <- #{peek XAnyEvent, serial} p send_event <- #{peek XAnyEvent, send_event} p display <- fmap Display (#{peek XAnyEvent, display} p) case () of ------------------------- -- ConfigureRequestEvent: ------------------------- _ | type_ == configureRequest -> do parent <- #{peek XConfigureRequestEvent, parent } p window <- #{peek XConfigureRequestEvent, window } p x <- #{peek XConfigureRequestEvent, x } p y <- #{peek XConfigureRequestEvent, y } p width <- #{peek XConfigureRequestEvent, width } p height <- #{peek XConfigureRequestEvent, height } p border_width <- #{peek XConfigureRequestEvent, border_width} p above <- #{peek XConfigureRequestEvent, above } p detail <- #{peek XConfigureRequestEvent, detail } p value_mask <- #{peek XConfigureRequestEvent, value_mask } p return $ ConfigureRequestEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_parent = parent , ev_window = window , ev_x = x , ev_y = y , ev_width = width , ev_height = height , ev_border_width = border_width , ev_above = above , ev_detail = detail , ev_value_mask = value_mask } ------------------ -- ConfigureEvent: ------------------ | type_ == configureNotify -> do return (ConfigureEvent type_ serial send_event display) `ap` #{peek XConfigureEvent, event } p `ap` #{peek XConfigureEvent, window } p `ap` #{peek XConfigureEvent, x } p `ap` #{peek XConfigureEvent, y } p `ap` #{peek XConfigureEvent, width } p `ap` #{peek XConfigureEvent, height } p `ap` #{peek XConfigureEvent, border_width } p `ap` #{peek XConfigureEvent, above } p `ap` #{peek XConfigureEvent, override_redirect } p ------------------- -- MapRequestEvent: ------------------- | type_ == mapRequest -> do parent <- #{peek XMapRequestEvent, parent} p window <- #{peek XMapRequestEvent, window} p return $ MapRequestEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_parent = parent , ev_window = window } ------------------- -- MapNotifyEvent ------------------- | type_ == mapNotify -> do event <- #{peek XMapEvent, event} p window <- #{peek XMapEvent, window} p override_redirect <- #{peek XMapEvent, override_redirect} p return $ MapNotifyEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_event = event , ev_window = window , ev_override_redirect = override_redirect } ------------------- -- MappingNotifyEvent ------------------- | type_ == mappingNotify -> do window <- #{peek XMappingEvent,window} p request <- #{peek XMappingEvent,request} p first_keycode <- #{peek XMappingEvent,first_keycode} p count <- #{peek XMappingEvent,count} p return $ MappingNotifyEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_window = window , ev_request = request , ev_first_keycode = first_keycode , ev_count = count } ------------ -- KeyEvent: ------------ | type_ == keyPress || type_ == keyRelease -> do window <- #{peek XKeyEvent, window } p root <- #{peek XKeyEvent, root } p subwindow <- #{peek XKeyEvent, subwindow } p time <- #{peek XKeyEvent, time } p x <- #{peek XKeyEvent, x } p y <- #{peek XKeyEvent, y } p x_root <- #{peek XKeyEvent, x_root } p y_root <- #{peek XKeyEvent, y_root } p state <- (#{peek XKeyEvent, state } p) :: IO CUInt keycode <- #{peek XKeyEvent, keycode } p same_screen <- #{peek XKeyEvent, same_screen} p return $ KeyEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_window = window , ev_root = root , ev_subwindow = subwindow , ev_time = time , ev_x = x , ev_y = y , ev_x_root = x_root , ev_y_root = y_root , ev_state = fromIntegral state , ev_keycode = keycode , ev_same_screen = same_screen } --------------- -- ButtonEvent: --------------- | type_ == buttonPress || type_ == buttonRelease -> do window <- #{peek XButtonEvent, window } p root <- #{peek XButtonEvent, root } p subwindow <- #{peek XButtonEvent, subwindow } p time <- #{peek XButtonEvent, time } p x <- #{peek XButtonEvent, x } p y <- #{peek XButtonEvent, y } p x_root <- #{peek XButtonEvent, x_root } p y_root <- #{peek XButtonEvent, y_root } p state <- (#{peek XButtonEvent, state } p) :: IO CUInt button <- #{peek XButtonEvent, button } p same_screen <- #{peek XButtonEvent, same_screen} p return $ ButtonEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_window = window , ev_root = root , ev_subwindow = subwindow , ev_time = time , ev_x = x , ev_y = y , ev_x_root = x_root , ev_y_root = y_root , ev_state = fromIntegral state , ev_button = button , ev_same_screen = same_screen } ---------------------- -- DestroyWindowEvent: ---------------------- | type_ == destroyNotify -> do event <- #{peek XDestroyWindowEvent, event } p window <- #{peek XDestroyWindowEvent, window} p return $ DestroyWindowEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_event = event , ev_window = window } -------------------- -- UnmapNotifyEvent: -------------------- | type_ == unmapNotify -> do event <- #{peek XUnmapEvent, event } p window <- #{peek XUnmapEvent, window } p from_configure <- #{peek XUnmapEvent, from_configure} p return $ UnmapEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_event = event , ev_window = window , ev_from_configure = from_configure } -------------------- -- CrossingEvent -------------------- | type_ == enterNotify || type_ == leaveNotify -> do window <- #{peek XCrossingEvent, window } p root <- #{peek XCrossingEvent, root } p subwindow <- #{peek XCrossingEvent, subwindow } p time <- #{peek XCrossingEvent, time } p x <- #{peek XCrossingEvent, x } p y <- #{peek XCrossingEvent, y } p x_root <- #{peek XCrossingEvent, x_root } p y_root <- #{peek XCrossingEvent, y_root } p mode <- #{peek XCrossingEvent, mode } p detail <- #{peek XCrossingEvent, detail } p same_screen <- #{peek XCrossingEvent, same_screen } p focus <- #{peek XCrossingEvent, focus } p state <- (#{peek XCrossingEvent, state } p) :: IO CUInt return $ CrossingEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_window = window , ev_root = root , ev_subwindow = subwindow , ev_time = time , ev_x = x , ev_y = y , ev_x_root = x_root , ev_y_root = y_root , ev_mode = mode , ev_detail = detail , ev_same_screen = same_screen , ev_focus = focus , ev_state = fromIntegral state } -- We don't handle this event specifically, so return the generic -- AnyEvent. | otherwise -> do window <- #{peek XAnyEvent, window} p return $ AnyEvent { ev_event_type = type_ , ev_serial = serial , ev_send_event = send_event , ev_event_display = display , ev_window = window } data WindowChanges = WindowChanges { wc_x :: CInt , wc_y :: CInt , wc_width :: CInt , wc_height:: CInt , wc_border_width :: CInt , wc_sibling :: Window , wc_stack_mode :: CInt } instance Storable WindowChanges where sizeOf _ = #{size XWindowChanges} -- I really hope this is right: alignment _ = alignment (undefined :: CInt) poke p wc = do #{poke XWindowChanges, x } p $ wc_x wc #{poke XWindowChanges, y } p $ wc_y wc #{poke XWindowChanges, width } p $ wc_width wc #{poke XWindowChanges, height } p $ wc_height wc #{poke XWindowChanges, border_width} p $ wc_border_width wc #{poke XWindowChanges, sibling } p $ wc_sibling wc #{poke XWindowChanges, stack_mode } p $ wc_stack_mode wc peek p = return WindowChanges `ap` (#{peek XWindowChanges, x} p) `ap` (#{peek XWindowChanges, y} p) `ap` (#{peek XWindowChanges, width} p) `ap` (#{peek XWindowChanges, height} p) `ap` (#{peek XWindowChanges, border_width} p) `ap` (#{peek XWindowChanges, sibling} p) `ap` (#{peek XWindowChanges, stack_mode} p) -- -- Some extra constants -- none :: XID none = #{const None} anyButton :: Button anyButton = #{const AnyButton} anyKey :: KeyCode anyKey = toEnum #{const AnyKey} currentTime :: Time currentTime = #{const CurrentTime} -- -- The use of Int rather than CInt isn't 64 bit clean. -- foreign import ccall unsafe "XlibExtras.h XConfigureWindow" xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO CInt foreign import ccall unsafe "XlibExtras.h XKillClient" killClient :: Display -> Window -> IO CInt configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO () configureWindow d w m c = do with c (xConfigureWindow d w m) return () foreign import ccall unsafe "XlibExtras.h XFree" xFree :: Ptr a -> IO CInt foreign import ccall unsafe "XlibExtras.h XQueryTree" xQueryTree :: Display -> Window -> Ptr Window -> Ptr Window -> Ptr (Ptr Window) -> Ptr CInt -> IO Status queryTree :: Display -> Window -> IO (Window, Window, [Window]) queryTree d w = alloca $ \root_return -> alloca $ \parent_return -> alloca $ \children_return -> alloca $ \nchildren_return -> do xQueryTree d w root_return parent_return children_return nchildren_return p <- peek children_return n <- fmap fromIntegral $ peek nchildren_return ws <- peekArray n p xFree p liftM3 (,,) (peek root_return) (peek parent_return) (return ws) -- TODO: this data type is incomplete wrt. the C struct data WindowAttributes = WindowAttributes { wa_x, wa_y, wa_width, wa_height, wa_border_width :: CInt , wa_map_state :: CInt , wa_override_redirect :: Bool } instance Storable WindowAttributes where -- this might be incorrect alignment _ = alignment (undefined :: CInt) sizeOf _ = #{size XWindowAttributes} peek p = return WindowAttributes `ap` (#{peek XWindowAttributes, x } p) `ap` (#{peek XWindowAttributes, y } p) `ap` (#{peek XWindowAttributes, width } p) `ap` (#{peek XWindowAttributes, height } p) `ap` (#{peek XWindowAttributes, border_width } p) `ap` (#{peek XWindowAttributes, map_state } p) `ap` (#{peek XWindowAttributes, override_redirect} p) poke p wa = do #{poke XWindowAttributes, x } p $ wa_x wa #{poke XWindowAttributes, y } p $ wa_y wa #{poke XWindowAttributes, width } p $ wa_width wa #{poke XWindowAttributes, height } p $ wa_height wa #{poke XWindowAttributes, border_width } p $ wa_border_width wa #{poke XWindowAttributes, map_state } p $ wa_map_state wa #{poke XWindowAttributes, override_redirect} p $ wa_override_redirect wa foreign import ccall unsafe "XlibExtras.h XGetWindowAttributes" xGetWindowAttributes :: Display -> Window -> Ptr (WindowAttributes) -> IO Status getWindowAttributes d w = alloca $ \p -> do xGetWindowAttributes d w p peek p waIsViewable :: CInt waIsViewable = fromIntegral $ #{const IsViewable} -- | Run an action with the server withServer :: Display -> IO () -> IO () withServer dpy f = do grabServer dpy f ungrabServer dpy foreign import ccall unsafe "XlibExtras.h XFetchName" xFetchName :: Display -> Window -> Ptr CString -> IO Status fetchName :: Display -> Window -> IO (Maybe String) fetchName d w = alloca $ \p -> do xFetchName d w p cstr <- peek p if cstr == nullPtr then return Nothing else do str <- peekCString cstr xFree cstr return $ Just str foreign import ccall unsafe "XlibExtras.h XGetTransientForHint" xGetTransientForHint :: Display -> Window -> Ptr Window -> IO Status getTransientForHint :: Display -> Window -> IO (Maybe Window) getTransientForHint d w = alloca $ \wp -> do status <- xGetTransientForHint d w wp if status == 0 then return Nothing else Just `liftM` peek wp ------------------------------------------------------------------------ -- setWMProtocols :: Display -> Window -> [Atom] -> IO () {- setWMProtocols :: Display -> Window -> [Atom] -> IO () setWMProtocols display w protocols = withArray protocols $ \ protocol_array -> xSetWMProtocols display w protocol_array (length protocols) foreign import ccall unsafe "HsXlib.h XSetWMProtocols" xSetWMProtocols :: Display -> Window -> Ptr Atom -> CInt -> IO () -} -- | The XGetWMProtocols function returns the list of atoms -- stored in the WM_PROTOCOLS property on the specified win­ -- dow. These atoms describe window manager protocols in -- which the owner of this window is willing to participate. -- If the property exists, is of type ATOM, is of format 32, -- and the atom WM_PROTOCOLS can be interned, XGetWMProtocols -- sets the protocols_return argument to a list of atoms, -- sets the count_return argument to the number of elements -- in the list, and returns a nonzero status. Otherwise, it -- sets neither of the return arguments and returns a zero -- status. To release the list of atoms, use XFree. -- getWMProtocols :: Display -> Window -> IO [Atom] getWMProtocols display w = do alloca $ \atom_ptr_ptr -> alloca $ \count_ptr -> do st <- xGetWMProtocols display w atom_ptr_ptr count_ptr if st == 0 then return [] else do sz <- peek count_ptr print sz atom_ptr <- peek atom_ptr_ptr atoms <- peekArray (fromIntegral sz) atom_ptr xFree atom_ptr return atoms foreign import ccall unsafe "HsXlib.h XGetWMProtocols" xGetWMProtocols :: Display -> Window -> Ptr (Ptr Atom) -> Ptr CInt -> IO Status ------------------------------------------------------------------------ -- Creating events setEventType :: XEventPtr -> EventType -> IO () setEventType = #{poke XEvent,type} -- hacky way to set up an XClientMessageEvent -- Should have a Storable instance for XEvent/Event? setClientMessageEvent :: XEventPtr -> Window -> Atom -> CInt -> Atom -> Time -> IO () setClientMessageEvent p window message_type format l_0_ l_1_ = do #{poke XClientMessageEvent, window} p window #{poke XClientMessageEvent, message_type} p message_type #{poke XClientMessageEvent, format} p format let datap = #{ptr XClientMessageEvent, data} p :: Ptr CLong poke datap (fromIntegral l_0_) -- does this work? pokeElemOff datap 1 (fromIntegral l_1_) return () {- typedef struct { int type; /* ClientMessage */ unsigned long serial; /* # of last request processed by server */ Bool send_event; /* true if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window window; Atom message_type; int format; union { char b[20]; short s[10]; long l[5]; } data; } XClientMessageEvent; -} ------------------------------------------------------------------------ -- XErrorEvents -- -- I'm too lazy to write the binding -- foreign import ccall unsafe "XlibExtras.h x11_extras_set_error_handler" xSetErrorHandler :: IO () -- | refreshKeyboardMapping. TODO Remove this binding when the fix has been commited to -- X11 refreshKeyboardMapping :: Event -> IO () refreshKeyboardMapping ev@(MappingNotifyEvent {ev_event_display = (Display d)}) = allocaBytes #{size XMappingEvent} $ \p -> do #{poke XMappingEvent, type } p $ ev_event_type ev #{poke XMappingEvent, serial } p $ ev_serial ev #{poke XMappingEvent, send_event } p $ ev_send_event ev #{poke XMappingEvent, display } p $ d #{poke XMappingEvent, window } p $ ev_window ev #{poke XMappingEvent, request } p $ ev_request ev #{poke XMappingEvent, first_keycode } p $ ev_first_keycode ev #{poke XMappingEvent, count } p $ ev_count ev xRefreshKeyboardMapping p return () refreshKeyboardMapping _ = return () foreign import ccall unsafe "XlibExtras.h XRefreshKeyboardMapping" xRefreshKeyboardMapping :: Ptr () -> IO CInt -- Properties foreign import ccall unsafe "XlibExtras.h XChangeProperty" xChangeProperty :: Display -> Window -> Atom -> Atom -> CInt -> CInt -> Ptr CUChar -> CInt -> IO Status -- this assumes bytes are 8 bits. I hope X isn't more portable than that :( changeProperty8 :: Display -> Window -> Atom -> Atom -> CInt -> [Char] -> IO () changeProperty8 dpy w prop typ mode dat = withArrayLen (map (fromIntegral . fromEnum) dat) $ \ len ptr -> do xChangeProperty dpy w prop typ 8 mode ptr (fromIntegral len) return () propModeReplace, propModePrepend, propModeAppend :: CInt propModeReplace = #{const PropModeReplace} propModePrepend = #{const PropModePrepend} propModeAppend = #{const PropModeAppend}