{-# LANGUAGE CPP #-} {- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include -#include -fvia-C -} module EncodeEvent(getNextEvent,motionCompress) where import Event import Xtypes --import ResourceIds import XCallTypes import StructFuns import Xlib import Marshall import MyForeign import qualified Foreign as F import FudUTF8(decodeUTF8) import Data.Maybe(fromMaybe) --import Ap --import GlaExts hiding(Word) --(primIOToIO,CCallable,CReturnable,Addr) --import MutableArray(MutableByteArray#) --import PrelGHC --import PrelBase --import GhcWord --import CString(unpackCStringIO) --import Command --import Font #include "newstructfuns.h" getNextEvent d = do ev <- newXEvent xNextEvent d ev window <- GET(XAnyEvent,WindowId,ev,window) fev <- encodeEvent ev return (window,fev) -- no freePtr?! checkWindowEvent d w evmask = do ev <- newXEvent found <- xCheckWindowEvent d w (toC (evmask::[EventMask])) ev if found then Just <$> encodeEvent ev else freePtr ev >> return Nothing motionCompress d e@(w,fev@MotionNotify{}) = do me <- checkWindowEvent d w [PointerMotionMask] case me of Nothing -> return e Just fev' -> motionCompress d (w,fev') motionCompress _ e = return e encodeEvent ev = do evno <- GET(XAnyEvent,Int,ev,type) case evno :: Int of {- ghc doesn't handle literal (``KeyPress'') patterns yet -} #define X_KeyPress 2 #define X_KeyRelease 3 #define X_ButtonPress 4 #define X_ButtonRelease 5 #define X_MotionNotify 6 #define X_EnterNotify 7 #define X_LeaveNotify 8 #define X_FocusIn 9 #define X_FocusOut 10 #define X_KeymapNotify 11 #define X_Expose 12 #define X_GraphicsExpose 13 #define X_NoExpose 14 #define X_VisibilityNotify 15 #define X_CreateNotify 16 #define X_DestroyNotify 17 #define X_UnmapNotify 18 #define X_MapNotify 19 #define X_MapRequest 20 #define X_ReparentNotify 21 #define X_ConfigureNotify 22 #define X_ConfigureRequest 23 #define X_GravityNotify 24 #define X_ResizeRequest 25 #define X_CirculateNotify 26 #define X_CirculateRequest 27 #define X_PropertyNotify 28 #define X_SelectionClear 29 #define X_SelectionRequest 30 #define X_SelectionNotify 31 #define X_ColormapNotify 32 #define X_ClientMessage 33 #define X_MappingNotify 34 X_KeyPress -> putKeyEvent ev Pressed X_KeyRelease -> putKeyEvent ev Released X_ButtonPress -> putButtonEvent ev Pressed X_ButtonRelease -> putButtonEvent ev Released X_MotionNotify -> putMotionEvent ev X_EnterNotify -> putCrossingEvent ev True X_LeaveNotify -> putCrossingEvent ev False X_FocusIn -> putFocusChangeEvent ev True X_FocusOut -> putFocusChangeEvent ev False X_KeymapNotify -> return KeymapNotify X_Expose -> putExposeEvent ev X_GraphicsExpose -> putGraphicsExposeEvent ev X_NoExpose -> return NoExpose X_VisibilityNotify -> putVisibilityEvent ev X_CreateNotify -> putStructEvent ev CreateNotify X_DestroyNotify -> putStructEvent ev DestroyNotify X_UnmapNotify -> putStructEvent ev UnmapNotify X_MapNotify -> putStructEvent ev MapNotify X_MapRequest -> putStructEvent ev MapRequest X_ReparentNotify -> return ReparentNotify X_ConfigureNotify -> putConfigureEvent ev X_ConfigureRequest -> return ConfigureRequest X_GravityNotify -> return GravityNotify X_ResizeRequest -> putResizeRequestEvent ev X_CirculateNotify -> return CirculateNotify X_CirculateRequest -> return CirculateRequest X_PropertyNotify -> return PropertyNotify X_SelectionClear -> putSelectionClearEvent ev X_SelectionRequest -> putSelectionRequestEvent ev X_SelectionNotify -> putSelectionNotifyEvent ev X_ColormapNotify -> return ColormapNotify X_ClientMessage -> putClientMessageEvent ev X_MappingNotify -> return MappingNotify mkClientData ev = do format <- GET(XClientMessageEvent,Int,ev,format) d <- AGET(XClientMessageEvent,Addr,ev,data) case format::Int of 32 -> Long <$> mapM (CINDEX(long) (d::Addr)) [0..(4::Int)] 16 -> Short <$> mapM (CINDEX(short) d) [0..(9::Int)] 8 -> Byte <$> mapM (CINDEX(char) d) [0..(19::Int)] putKeyEvent ev p = do (key,l) <- xLookupString ev 100 KeyEvent <$> GET(XKeyEvent,Time,ev,time) <*> mkPoint GET(XKeyEvent,Int,ev,x) GET(XKeyEvent,Int,ev,y) <*> mkPoint GET(XKeyEvent,Int,ev,x_root) GET(XKeyEvent,Int,ev,y_root) <*> fmap fromC GET(XKeyEvent,Int,ev,state) <*> return p <*> fmap KeyCode GET(XKeyEvent,Int,ev,keycode) <*> return key <*> return (decodeUTF8 l) -- !! Assume that XLookupString returns a UTF-8 string -- https://gitlab.freedesktop.org/xorg/lib/libx11/-/issues/39 putButtonEvent ev p = ButtonEvent <$> GET(XButtonEvent,Time,ev,time) <*> mkPoint GET(XButtonEvent,Int,ev,x) GET(XButtonEvent,Int,ev,y) <*> mkPoint GET(XButtonEvent,Int,ev,x_root) GET(XButtonEvent,Int,ev,y_root) <*> fmap fromC GET(XButtonEvent,Int,ev,state) <*> return p <*> fmap Button GET(XButtonEvent,Int,ev,button) putMotionEvent ev = MotionNotify <$> GET(XMotionEvent,Time,ev,time) <*> mkPoint GET(XMotionEvent,Int,ev,x) GET(XMotionEvent,Int,ev,y) <*> mkPoint GET(XMotionEvent,Int,ev,x_root) GET(XMotionEvent,Int,ev,y_root) <*> fmap fromC GET(XMotionEvent,Int,ev,state) putCrossingEvent ev c = (if c then EnterNotify else LeaveNotify) <$> GET(XCrossingEvent,Time,ev,time) <*> mkPoint GET(XCrossingEvent,Int,ev,x) GET(XCrossingEvent,Int,ev,y) <*> mkPoint GET(XCrossingEvent,Int,ev,x_root) GET(XCrossingEvent,Int,ev,y_root) <*> fmap fromC GET(XCrossingEvent,Int,ev,detail) <*> fmap fromC GET(XCrossingEvent,Int,ev,mode) <*> fmap fromC GET(XCrossingEvent,Int,ev,focus) putFocusChangeEvent ev c = (if c then FocusIn else FocusOut) <$> fmap fromC GET(XFocusChangeEvent,Int,ev,detail) <*> fmap fromC GET(XFocusChangeEvent,Int,ev,mode) putExposeEvent ev = Expose <$> mkRect GET(XExposeEvent,Int,ev,x) GET(XExposeEvent,Int,ev,y) GET(XExposeEvent,Int,ev,width) GET(XExposeEvent,Int,ev,height) <*> GET(XExposeEvent,Int,ev,count) putGraphicsExposeEvent ev = GraphicsExpose <$> mkRect GET(XGraphicsExposeEvent,Int,ev,x) GET(XGraphicsExposeEvent,Int,ev,y) GET(XGraphicsExposeEvent,Int,ev,width) GET(XGraphicsExposeEvent,Int,ev,height) <*> GET(XGraphicsExposeEvent,Int,ev,count) <*> GET(XGraphicsExposeEvent,Int,ev,major_code) <*> GET(XGraphicsExposeEvent,Int,ev,minor_code) putVisibilityEvent ev = VisibilityNotify . fromC <$> GET(XVisibilityEvent,Int,ev,state) putStructEvent ev c = c <$> GET(XMapEvent,WindowId,ev,window) putConfigureEvent ev = ConfigureNotify <$> mkRect GET(XConfigureEvent,Int,ev,x) GET(XConfigureEvent,Int,ev,y) GET(XConfigureEvent,Int,ev,width) GET(XConfigureEvent,Int,ev,height) <*> GET(XConfigureEvent,Int,ev,border_width) putResizeRequestEvent ev = ResizeRequest <$> mkPoint GET(XResizeRequestEvent,Int,ev,width) GET(XResizeRequestEvent,Int,ev,height) putSelectionClearEvent ev = SelectionClear <$> GET(XSelectionClearEvent,Atom,ev,selection) putSelectionRequestEvent ev = SelectionRequest <$> GET(XSelectionRequestEvent,Time,ev,time) <*> GET(XSelectionRequestEvent,WindowId,ev,requestor) <*> (Selection <$> GET(XSelectionRequestEvent,Atom,ev,selection) <*> GET(XSelectionRequestEvent,Atom,ev,target) <*> GET(XSelectionRequestEvent,Atom,ev,property)) putSelectionNotifyEvent ev = SelectionNotify <$> GET(XSelectionEvent,Time,ev,time) <*> (Selection <$> GET(XSelectionEvent,Atom,ev,selection) <*> GET(XSelectionEvent,Atom,ev,target) <*> GET(XSelectionEvent,Atom,ev,property)) putClientMessageEvent ev = ClientMessage <$> GET(XClientMessageEvent,Atom,ev,message_type) <*> mkClientData ev foreign import ccall "X11/Xlib.h XLookupString" cXLookupString :: CXKeyEvent -> Addr -> Int -> F.Ptr XlibKeySym -> Addr -> IO Int xLookupString :: CXKeyEvent -> Int -> IO (KeySym,String) xLookupString xev len = alloca len $ \ arr -> F.alloca $ \ keysyma -> do len' <- {- _casm_ ``%r=(int)XLookupString((XKeyEvent *)%0, (char *)%1, (int)%2, (KeySym *)%3, NULL);'' xev arr len keysyma -} cXLookupString xev arr len keysyma nullAddr keysym <- F.peek keysyma key <- xKeysymToString keysym let key' = fromMaybe "(undefined)" key str <- unmarshallString' (CString arr) len' return (key',str) instance FromC Detail where fromC = toEnum' NotifyAncestor instance FromC Mode where fromC = toEnum' NotifyNormal instance FromC Visibility where fromC = toEnum' VisibilityUnobscured instance F.Storable XID where sizeOf (XID x) = F.sizeOf x alignment (XID x) = F.alignment x peek a = fmap XID (F.peek (F.castPtr a)) poke a (XID x) = F.poke (F.castPtr a) x