{-# LANGUAGE CPP #-}
module EncodeEvent(getNextEvent,motionCompress) where
import Event
import Xtypes
import XCallTypes
import StructFuns
import Xlib
import Marshall
import MyForeign
import qualified Foreign as F
import FudUTF8(decodeUTF8)
import Data.Maybe(fromMaybe)
#include "newstructfuns.h"
getNextEvent :: Display -> IO (WindowId, XEvent)
getNextEvent Display
d = do
CXEvent
ev <- IO CXEvent
newXEvent
Display -> CXEvent -> IO ()
xNextEvent Display
d CXEvent
ev
WindowId
window <- GET(XAnyEvent,WindowId,ev,window)
XEvent
fev <- CXEvent -> IO XEvent
encodeEvent CXEvent
ev
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowId
window,XEvent
fev)
checkWindowEvent :: Display -> WindowId -> [EventMask] -> IO (Maybe XEvent)
checkWindowEvent Display
d WindowId
w [EventMask]
evmask = do
CXEvent
ev <- IO CXEvent
newXEvent
Bool
found <- Display -> WindowId -> Int -> CXEvent -> IO Bool
xCheckWindowEvent Display
d WindowId
w (forall a. ToC a => a -> Int
toC ([EventMask]
evmask::[EventMask])) CXEvent
ev
if Bool
found
then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CXEvent -> IO XEvent
encodeEvent CXEvent
ev
else forall {a}. HasAddr a => a -> IO ()
freePtr CXEvent
ev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
motionCompress :: Display -> (WindowId, XEvent) -> IO (WindowId, XEvent)
motionCompress Display
d e :: (WindowId, XEvent)
e@(WindowId
w,fev :: XEvent
fev@MotionNotify{}) =
do Maybe XEvent
me <- Display -> WindowId -> [EventMask] -> IO (Maybe XEvent)
checkWindowEvent Display
d WindowId
w [EventMask
PointerMotionMask]
case Maybe XEvent
me of
Maybe XEvent
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (WindowId, XEvent)
e
Just XEvent
fev' -> Display -> (WindowId, XEvent) -> IO (WindowId, XEvent)
motionCompress Display
d (WindowId
w,XEvent
fev')
motionCompress Display
_ (WindowId, XEvent)
e = forall (m :: * -> *) a. Monad m => a -> m a
return (WindowId, XEvent)
e
encodeEvent :: CXEvent -> IO XEvent
encodeEvent CXEvent
ev = do
Int
evno <- GET(XAnyEvent,Int,ev,type)
case Int
evno :: Int of
#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 :: CXEvent -> IO ClientData
mkClientData CXEvent
ev = do
Int
format <- GET(XClientMessageEvent,Int,ev,format)
Addr
d <- AGET(XClientMessageEvent,Addr,ev,data)
case Int
format::Int of
Int
32 -> [Int] -> ClientData
Long forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CINDEX(long) Addr
(d::Addr)) Int
[0..(4::Int)]
Int
16 -> [Int] -> ClientData
Short forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CINDEX(short) d) Int
[0..(9::Int)]
Int
8 -> String -> ClientData
Byte forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CINDEX(char) d) Int
[0..(19::Int)]
putKeyEvent :: CXEvent -> Pressed -> IO XEvent
putKeyEvent CXEvent
ev Pressed
p = do
(String
key,String
l) <- CXEvent -> Int -> IO (String, String)
xLookupString CXEvent
ev Int
100
Int
-> Point
-> Point
-> ModState
-> Pressed
-> KeyCode
-> String
-> String
-> XEvent
KeyEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XKeyEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XKeyEvent,Int,ev,x) GET(XKeyEvent,Int,ev,y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XKeyEvent,Int,ev,x_root) GET(XKeyEvent,Int,ev,y_root)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XKeyEvent,Int,ev,state)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Pressed
p
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> KeyCode
KeyCode GET(XKeyEvent,Int,ev,keycode)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return String
key
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
decodeUTF8 String
l)
putButtonEvent :: CXEvent -> Pressed -> IO XEvent
putButtonEvent CXEvent
ev Pressed
p =
Int -> Point -> Point -> ModState -> Pressed -> Button -> XEvent
ButtonEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XButtonEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XButtonEvent,Int,ev,x) GET(XButtonEvent,Int,ev,y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XButtonEvent,Int,ev,x_root) GET(XButtonEvent,Int,ev,y_root)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XButtonEvent,Int,ev,state)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Pressed
p
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Button
Button GET(XButtonEvent,Int,ev,button)
putMotionEvent :: CXEvent -> IO XEvent
putMotionEvent CXEvent
ev =
Int -> Point -> Point -> ModState -> XEvent
MotionNotify
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XMotionEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XMotionEvent,Int,ev,x) GET(XMotionEvent,Int,ev,y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XMotionEvent,Int,ev,x_root) GET(XMotionEvent,Int,ev,y_root)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XMotionEvent,Int,ev,state)
putCrossingEvent :: CXEvent -> Bool -> IO XEvent
putCrossingEvent CXEvent
ev Bool
c =
(if Bool
c then Int -> Point -> Point -> Detail -> Mode -> Bool -> XEvent
EnterNotify else Int -> Point -> Point -> Detail -> Mode -> Bool -> XEvent
LeaveNotify)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XCrossingEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XCrossingEvent,Int,ev,x) GET(XCrossingEvent,Int,ev,y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XCrossingEvent,Int,ev,x_root) GET(XCrossingEvent,Int,ev,y_root)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XCrossingEvent,Int,ev,detail)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XCrossingEvent,Int,ev,mode)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XCrossingEvent,Int,ev,focus)
putFocusChangeEvent :: CXEvent -> Bool -> IO XEvent
putFocusChangeEvent CXEvent
ev Bool
c =
(if Bool
c then Detail -> Mode -> XEvent
FocusIn else Detail -> Mode -> XEvent
FocusOut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XFocusChangeEvent,Int,ev,detail)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromC a => Int -> a
fromC GET(XFocusChangeEvent,Int,ev,mode)
putExposeEvent :: CXEvent -> IO XEvent
putExposeEvent CXEvent
ev =
Rect -> Int -> XEvent
Expose
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}.
Applicative f =>
f Int -> f Int -> f Int -> f Int -> f Rect
mkRect GET(XExposeEvent,Int,ev,x) GET(XExposeEvent,Int,ev,y)
GET(XExposeEvent,Int,ev,width) GET(XExposeEvent,Int,ev,height)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XExposeEvent,Int,ev,count)
putGraphicsExposeEvent :: CXEvent -> IO XEvent
putGraphicsExposeEvent CXEvent
ev =
Rect -> Int -> Int -> Int -> XEvent
GraphicsExpose
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}.
Applicative f =>
f Int -> f Int -> f Int -> f Int -> f Rect
mkRect GET(XGraphicsExposeEvent,Int,ev,x) GET(XGraphicsExposeEvent,Int,ev,y)
GET(XGraphicsExposeEvent,Int,ev,width) GET(XGraphicsExposeEvent,Int,ev,height)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XGraphicsExposeEvent,Int,ev,count)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XGraphicsExposeEvent,Int,ev,major_code)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XGraphicsExposeEvent,Int,ev,minor_code)
putVisibilityEvent :: CXEvent -> IO XEvent
putVisibilityEvent CXEvent
ev =
Visibility -> XEvent
VisibilityNotify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromC a => Int -> a
fromC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XVisibilityEvent,Int,ev,state)
putStructEvent :: CXEvent -> (WindowId -> b) -> IO b
putStructEvent CXEvent
ev WindowId -> b
c = WindowId -> b
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XMapEvent,WindowId,ev,window)
putConfigureEvent :: CXEvent -> IO XEvent
putConfigureEvent CXEvent
ev =
Rect -> Int -> XEvent
ConfigureNotify
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}.
Applicative f =>
f Int -> f Int -> f Int -> f Int -> f Rect
mkRect GET(XConfigureEvent,Int,ev,x) GET(XConfigureEvent,Int,ev,y)
GET(XConfigureEvent,Int,ev,width) GET(XConfigureEvent,Int,ev,height)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XConfigureEvent,Int,ev,border_width)
putResizeRequestEvent :: CXEvent -> IO XEvent
putResizeRequestEvent CXEvent
ev =
Point -> XEvent
ResizeRequest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}. Applicative f => f Int -> f Int -> f Point
mkPoint GET(XResizeRequestEvent,Int,ev,width)
GET(XResizeRequestEvent,Int,ev,height)
putSelectionClearEvent :: CXEvent -> IO XEvent
putSelectionClearEvent CXEvent
ev = Atom -> XEvent
SelectionClear
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XSelectionClearEvent,Atom,ev,selection)
putSelectionRequestEvent :: CXEvent -> IO XEvent
putSelectionRequestEvent CXEvent
ev =
Int -> WindowId -> Selection -> XEvent
SelectionRequest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XSelectionRequestEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XSelectionRequestEvent,WindowId,ev,requestor)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Atom -> Atom -> Atom -> Selection
Selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XSelectionRequestEvent,Atom,ev,selection)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XSelectionRequestEvent,Atom,ev,target)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XSelectionRequestEvent,Atom,ev,property))
putSelectionNotifyEvent :: CXEvent -> IO XEvent
putSelectionNotifyEvent CXEvent
ev =
Int -> Selection -> XEvent
SelectionNotify
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XSelectionEvent,Time,ev,time)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Atom -> Atom -> Atom -> Selection
Selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XSelectionEvent,Atom,ev,selection)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XSelectionEvent,Atom,ev,target)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XSelectionEvent,Atom,ev,property))
putClientMessageEvent :: CXEvent -> IO XEvent
putClientMessageEvent CXEvent
ev =
Atom -> ClientData -> XEvent
ClientMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XClientMessageEvent,Atom,ev,message_type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CXEvent -> IO ClientData
mkClientData CXEvent
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 :: CXEvent -> Int -> IO (String, String)
xLookupString CXEvent
xev Int
len =
forall {c}. Int -> (Addr -> IO c) -> IO c
alloca Int
len forall a b. (a -> b) -> a -> b
$ \ Addr
arr ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca forall a b. (a -> b) -> a -> b
$ \ Ptr XID
keysyma ->
do Int
len' <-
CXEvent -> Addr -> Int -> Ptr XID -> Addr -> IO Int
cXLookupString CXEvent
xev Addr
arr Int
len Ptr XID
keysyma Addr
nullAddr
XID
keysym <- forall a. Storable a => Ptr a -> IO a
F.peek Ptr XID
keysyma
Maybe String
key <- XID -> IO (Maybe String)
xKeysymToString XID
keysym
let key' :: String
key' = forall a. a -> Maybe a -> a
fromMaybe String
"(undefined)" Maybe String
key
String
str <- CString -> Int -> IO String
unmarshallString' (Addr -> CString
CString Addr
arr) Int
len'
forall (m :: * -> *) a. Monad m => a -> m a
return (String
key',String
str)
instance FromC Detail where fromC :: Int -> Detail
fromC = forall {a} {p}. Enum a => p -> Int -> a
toEnum' Detail
NotifyAncestor
instance FromC Mode where fromC :: Int -> Mode
fromC = forall {a} {p}. Enum a => p -> Int -> a
toEnum' Mode
NotifyNormal
instance FromC Visibility where fromC :: Int -> Visibility
fromC = forall {a} {p}. Enum a => p -> Int -> a
toEnum' Visibility
VisibilityUnobscured
instance F.Storable XID where
sizeOf :: XID -> Int
sizeOf (XID Int
x) = forall a. Storable a => a -> Int
F.sizeOf Int
x
alignment :: XID -> Int
alignment (XID Int
x) = forall a. Storable a => a -> Int
F.alignment Int
x
peek :: Ptr XID -> IO XID
peek Ptr XID
a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> XID
XID (forall a. Storable a => Ptr a -> IO a
F.peek (forall a b. Ptr a -> Ptr b
F.castPtr Ptr XID
a))
poke :: Ptr XID -> XID -> IO ()
poke Ptr XID
a (XID Int
x) = forall a. Storable a => Ptr a -> a -> IO ()
F.poke (forall a b. Ptr a -> Ptr b
F.castPtr Ptr XID
a) Int
x