{-# LANGUAGE CPP #-}
module DoXRequest(doXRequest,getGCValues,translateCoordinates) where
import Geometry
import Command
import Event
import Xtypes
import Font
import Visual
import HbcWord(intToWord)
import IOUtil(getEnvi)
import XCallTypes
import StructFuns
import Xlib
import Marshall
import MyForeign
import CString16
newXID :: IO CXID
newXID = IO CXID
forall a. IsPtr a => IO a
newPtr :: IO CXID
newLong :: IO CLong
newLong = IO CLong
forall a. IsPtr a => IO a
newPtr :: IO CLong
newLongs :: Int -> IO [CLong]
newLongs Int
n = [IO CLong] -> IO [CLong]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> IO CLong -> [IO CLong]
forall a. Int -> a -> [a]
replicate Int
n IO CLong
newLong)
readLong :: CLong -> IO Int
readLong = CLong -> IO Int
forall c h. CVar c h => c -> IO h
readCVar :: CLong -> IO Int
newInt32 :: IO CInt32
newInt32 = IO CInt32
forall a. IsPtr a => IO a
newPtr :: IO CInt32
newInt32s :: Int -> IO [CInt32]
newInt32s Int
n = [IO CInt32] -> IO [CInt32]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> IO CInt32 -> [IO CInt32]
forall a. Int -> a -> [a]
replicate Int
n IO CInt32
newInt32)
readInt32 :: CInt32 -> IO Int32
readInt32 = CInt32 -> IO Int32
forall c h. CVar c h => c -> IO h
readCVar :: CInt32 -> IO Int32
freePtrs :: t a -> IO ()
freePtrs t a
xs = (a -> IO ()) -> t a -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr t a
xs
doXRequest :: (Display, Window, XRequest) -> IO XResponse
doXRequest (d :: Display
d@Display
display,Window
wi,XRequest
req) =
case XRequest
req of
OpenDisplay DisplayName
optname ->
do DisplayName
name <- if DisplayName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DisplayName
optname
then case DisplayName -> Maybe DisplayName
getEnvi DisplayName
"DISPLAY" of
Just DisplayName
n -> DisplayName -> IO DisplayName
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayName
n
Maybe DisplayName
Nothing -> DisplayName -> IO DisplayName
forall a. DisplayName -> IO a
failu DisplayName
"DISPLAY variable is not set"
else DisplayName -> IO DisplayName
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayName
optname
Display
d <- DisplayName -> IO Display
xOpenDisplay DisplayName
name
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> XResponse
DisplayOpened Display
d)
CreateSimpleWindow Path
p Rect
r -> Window -> XResponse
WindowCreated (Window -> XResponse) -> IO Window -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> Rect -> IO Window
createWindow Window
wi Rect
r
CreateRootWindow Rect
r DisplayName
resname -> Window -> XResponse
WindowCreated (Window -> XResponse) -> IO Window -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Window
dr <- Display -> IO Window
xDefaultRootWindow Display
display
Window
this <- Window -> Rect -> IO Window
createWindow Window
dr Rect
r
Display -> Window -> DisplayName -> DisplayName -> IO ()
setClassHint Display
display Window
this DisplayName
resname DisplayName
"Fudgets"
/* This is a hack that solves a focus problem with twm.
The twm option NoTitleFocus also solves the problem. */
Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
this
CreateGC Drawable
dr GCId
oldgc GCAttributeList
gcattrs -> GCId -> XResponse
GCCreated (GCId -> XResponse) -> IO GCId -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Window
wi' <- if Window
wi Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
wi
XGCValuesMask
gcvals <- GCAttributeList -> IO XGCValuesMask
getGCValues GCAttributeList
gcattrs
GCId
gc <- Display -> DrawableId -> IO GCId
createGC Display
display (Window -> Drawable -> DrawableId
getdrawable Window
wi' Drawable
dr)
if GCId
oldgc GCId -> GCId -> Bool
forall a. Eq a => a -> a -> Bool
== GCId
rootGC then do
Int
screen <- Display -> IO Int
xDefaultScreen Display
display
Display -> GCId -> Int -> IO ()
xSetForeground Display
display GCId
gc (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> Int -> IO Int
xBlackPixel Display
display Int
screen
Display -> GCId -> Int -> IO ()
xSetBackground Display
display GCId
gc (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> Int -> IO Int
xWhitePixel Display
display Int
screen
else Display -> GCId -> GCId -> IO ()
copyGC Display
display GCId
oldgc GCId
gc
Display -> GCId -> XGCValuesMask -> IO ()
changeGC Display
display GCId
gc XGCValuesMask
gcvals
GCId -> IO GCId
forall (m :: * -> *) a. Monad m => a -> m a
return GCId
gc
LoadFont DisplayName
fn -> FontId -> XResponse
FontLoaded (FontId -> XResponse) -> IO FontId -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> DisplayName -> IO FontId
xLoadFont Display
display DisplayName
fn
CreateFontCursor Int
shp -> CursorId -> XResponse
CursorCreated (CursorId -> XResponse) -> IO CursorId -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Int -> IO CursorId
xCreateFontCursor Display
display Int
shp
GrabPointer Bool
b [EventMask]
evm ->
GrabPointerResult -> XResponse
PointerGrabbed (GrabPointerResult -> XResponse)
-> IO GrabPointerResult -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display
-> Window
-> Bool
-> Int
-> Int
-> Int
-> Window
-> CursorId
-> Int
-> IO GrabPointerResult
xGrabPointer Display
display Window
wi Bool
b ([EventMask] -> Int
forall a. ToC a => a -> Int
toC [EventMask]
evm)
Int
grabModeAsync Int
grabModeAsync Window
windowNone CursorId
cursorNone Int
currentTime
AllocNamedColor ColormapId
cm DisplayName
cn ->
Maybe Color -> XResponse
ColorAllocated (Maybe Color -> XResponse) -> IO (Maybe Color) -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Display -> DisplayName -> ColormapId -> IO (Maybe Color)
allocNamedColor Display
display DisplayName
cn (ColormapId -> IO (Maybe Color))
-> IO ColormapId -> IO (Maybe Color)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ColormapId -> IO ColormapId
dcm ColormapId
cm)
AllocColor ColormapId
cm RGB
rgb ->
Maybe Color -> XResponse
ColorAllocated (Maybe Color -> XResponse) -> IO (Maybe Color) -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Display -> RGB -> ColormapId -> IO (Maybe Color)
allocColor Display
display RGB
rgb (ColormapId -> IO (Maybe Color))
-> IO ColormapId -> IO (Maybe Color)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ColormapId -> IO ColormapId
dcm ColormapId
cm)
CreatePixmap (Point Int
w Int
h) Int
depth -> PixmapId -> XResponse
PixmapCreated (PixmapId -> XResponse) -> IO PixmapId -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Int
depth' <- if Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
copyFromParent
then Display -> Int -> IO Int
xDefaultDepth Display
display (Int -> IO Int) -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> IO Int
xDefaultScreen Display
display
else Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
depth
WindowId XID
wi' <- if Window
wi Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
wi
Display -> DrawableId -> Int -> Int -> Int -> IO PixmapId
xCreatePixmap Display
display (XID -> DrawableId
DrawableId XID
wi') Int
w Int
h Int
depth'
ReadBitmapFile DisplayName
filename -> do
CXID
bm <- IO CXID
newXID
ints :: [CInt32]
ints@[CInt32
w,CInt32
h,CInt32
xhot,CInt32
yhot] <- Int -> IO [CInt32]
newInt32s Int
4
WindowId XID
root <- Display -> IO Window
xDefaultRootWindow Display
display
CString
cfilename <- DisplayName -> IO CString
marshallString DisplayName
filename
Int
r <- Display
-> DrawableId
-> CString
-> CInt32
-> CInt32
-> CXID
-> CInt32
-> CInt32
-> IO Int
xReadBitmapFile Display
display (XID -> DrawableId
DrawableId XID
root) CString
cfilename CInt32
w CInt32
h CXID
bm CInt32
xhot CInt32
yhot
CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cfilename
Int
x <- Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> IO Int32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
xhot
BitmapReturn
ret <-
if (Int
r::Int) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CCONST(BitmapSuccess) then do
hot <- if x == -1 then return Nothing
else Just . Point x . fromIntegral <$> readInt32 yhot
BitmapReturn
<$> (Point <$> (fromIntegral <$> readInt32 w) <*> (fromIntegral <$> readInt32 h))
<*> return hot
<*> (PixmapId <$> readCVar bm)
else BitmapReturn -> IO BitmapReturn
forall (m :: * -> *) a. Monad m => a -> m a
return BitmapReturn
BitmapBad
[CInt32] -> IO ()
forall (t :: * -> *) a. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CInt32]
ints
CXID -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXID
bm
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (BitmapReturn -> XResponse
BitmapRead BitmapReturn
ret)
CreateBitmapFromData (BitmapData size :: Point
size@(Point Int
w Int
h) Maybe Point
hot [Int]
bytes) ->
do CString
cbytes <- DisplayName -> Int -> IO CString
marshallString' ((Int -> Char) -> [Int] -> DisplayName
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
forall a. Enum a => Int -> a
toEnum [Int]
bytes) (((Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
h)
WindowId XID
wi' <- if Window
wi Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
wi
let cw :: Int32
cw = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
ch :: Int32
ch = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
PixmapId
pm <- Display -> DrawableId -> CString -> Int32 -> Int32 -> IO PixmapId
xCreateBitmapFromData Display
display (XID -> DrawableId
DrawableId XID
wi') CString
cbytes Int32
cw Int32
ch
CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cbytes
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (BitmapReturn -> XResponse
BitmapRead (Point -> Maybe Point -> PixmapId -> BitmapReturn
BitmapReturn Point
size Maybe Point
hot PixmapId
pm))
XRequest
TranslateCoordinates ->
do Window
rootwin <- Display -> IO Window
xDefaultRootWindow Display
display
Point -> XResponse
CoordinatesTranslated (Point -> XResponse)
-> (Maybe Point -> Point) -> Maybe Point -> XResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> (Point -> Point) -> Maybe Point -> Point
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Point
origin Point -> Point
forall a. a -> a
id
(Maybe Point -> XResponse) -> IO (Maybe Point) -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Window -> Window -> IO (Maybe Point)
translateCoordinates Display
display Window
wi Window
rootwin
InternAtom DisplayName
str Bool
b -> Atom -> XResponse
GotAtom (Atom -> XResponse) -> IO Atom -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> DisplayName -> Bool -> IO Atom
xInternAtom Display
display DisplayName
str Bool
b
GetAtomName Atom
a ->
do CString
at_ret <- Display -> Atom -> IO CString
xGetAtomName Display
display Atom
a
if (CString
at_ret CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
nullStr)
then XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DisplayName -> XResponse
GotAtomName Maybe DisplayName
forall a. Maybe a
Nothing)
else
do DisplayName
at_name <- CString -> IO DisplayName
unmarshallString CString
at_ret
CString -> IO ()
forall a. HasAddr a => a -> IO ()
xFree CString
at_ret
case (DisplayName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DisplayName
at_name) of
Int
0 -> XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DisplayName -> XResponse
GotAtomName Maybe DisplayName
forall a. Maybe a
Nothing)
Int
_ -> XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DisplayName -> XResponse
GotAtomName (Maybe DisplayName -> XResponse) -> Maybe DisplayName -> XResponse
forall a b. (a -> b) -> a -> b
$ DisplayName -> Maybe DisplayName
forall a. a -> Maybe a
Just DisplayName
at_name)
GetWindowProperty Int
offset Atom
property Bool
delete Atom
req_type ->
do let length :: Int
length = Int
1000
CAtom
actual_type <- IO CAtom
forall a. IsPtr a => IO a
newPtr
CLong
actual_format <- IO CLong
forall a. IsPtr a => IO a
newPtr
CLong
nitems <- IO CLong
newLong
CLong
bytes_after <- IO CLong
newLong
CCString
prop_return <- IO CCString
newCString
Display
-> Window
-> Atom
-> Int
-> Int
-> Bool
-> Atom
-> CAtom
-> CLong
-> CLong
-> CLong
-> CCString
-> IO Int
xGetWindowProperty Display
display Window
wi Atom
property Int
offset
(Int
length Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
4::Int)) Bool
delete Atom
req_type
CAtom
actual_type CLong
actual_format CLong
nitems CLong
bytes_after CCString
prop_return
Atom
at <- CAtom -> IO Atom
forall c h. CVar c h => c -> IO h
readCVar CAtom
actual_type
Int
af <- CLong -> IO Int
forall c h. CVar c h => c -> IO h
readCVar CLong
actual_format
Int
n <- CLong -> IO Int
readLong CLong
nitems
Int
ba <- CLong -> IO Int
readLong CLong
bytes_after
DisplayName
str <- if (Int
af::Int) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CCONST(None) then return "" else
do let got :: Int
got = Int
afInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
CString
cstr <- CCString -> IO CString
forall c h. CVar c h => c -> IO h
readCVar CCString
prop_return
DisplayName
str <- CString -> Int -> IO DisplayName
unmarshallString' CString
cstr Int
got
CString -> IO ()
forall a. HasAddr a => a -> IO ()
xFree CString
cstr
DisplayName -> IO DisplayName
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayName
str
CAtom -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CAtom
actual_type
CLong -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CLong
actual_format
CLong -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CLong
nitems
CLong -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CLong
bytes_after
CCString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CCString
prop_return
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (XResponse -> IO XResponse) -> XResponse -> IO XResponse
forall a b. (a -> b) -> a -> b
$ Atom -> Int -> Int -> Int -> DisplayName -> XResponse
GotWindowProperty Atom
at Int
af Int
n Int
ba DisplayName
str
XRequest
QueryPointer -> do
ints :: [CLong]
ints@[CLong
root,CLong
child,CLong
root_x,CLong
root_y,CLong
win_x,CLong
win_y,CLong
mask] <- Int -> IO [CLong]
newLongs Int
7
Bool
same <- Display
-> Window
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> IO Bool
xQueryPointer Display
display Window
wi CLong
root CLong
child CLong
root_x CLong
root_y CLong
win_x CLong
win_y CLong
mask
XResponse
ret <- Bool -> Point -> Point -> ModState -> XResponse
PointerQueried Bool
same
(Point -> Point -> ModState -> XResponse)
-> IO Point -> IO (Point -> ModState -> XResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> IO Int -> IO Point
forall (f :: * -> *). Applicative f => f Int -> f Int -> f Point
mkPoint (CLong -> IO Int
readLong CLong
root_x) (CLong -> IO Int
readLong CLong
root_y)
IO (Point -> ModState -> XResponse)
-> IO Point -> IO (ModState -> XResponse)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Int -> IO Int -> IO Point
forall (f :: * -> *). Applicative f => f Int -> f Int -> f Point
mkPoint (CLong -> IO Int
readLong CLong
win_x) (CLong -> IO Int
readLong CLong
win_y)
IO (ModState -> XResponse) -> IO ModState -> IO XResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> ModState
forall a. FromC a => Int -> a
fromC (Int -> ModState) -> IO Int -> IO ModState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CLong -> IO Int
readLong CLong
mask)
[CLong] -> IO ()
forall (t :: * -> *) a. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CLong]
ints
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return XResponse
ret
QueryFont FontId
fid -> Maybe FontStructList -> XResponse
FontQueried (Maybe FontStructList -> XResponse)
-> IO (Maybe FontStructList) -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontId -> IO (Maybe FontStructList)
queryFont Display
display FontId
fid
LoadQueryFont DisplayName
fn -> Maybe FontStructList -> XResponse
FontQueried (Maybe FontStructList -> XResponse)
-> IO (Maybe FontStructList) -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> DisplayName -> IO (Maybe FontStructList)
loadQueryFont Display
display DisplayName
fn
QueryColor ColormapId
cmid (Pixel Word
px) -> do
CXColor
c <- IO CXColor
newXColor
SET(XColor,Word,c,pixel,px)
ColormapId
cm <- ColormapId -> IO ColormapId
dcm ColormapId
cmid
Display -> ColormapId -> CXColor -> IO ()
xQueryColor Display
display ColormapId
cm CXColor
c
Color
r <- CXColor -> IO Color
mkColor CXColor
c
CXColor -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXColor
c
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Color -> XResponse
ColorQueried Color
r)
ListFonts DisplayName
pattern Int
maxnames ->
do CLong
cnt <- IO CLong
newLong
CString
fnarr <- Display -> DisplayName -> Int -> CLong -> IO CString
xListFonts Display
display DisplayName
pattern Int
maxnames CLong
cnt
[DisplayName]
fns <- CString -> Int -> IO [DisplayName]
forall prim b c.
(PrimResult prim (IO b), CVar c prim) =>
c -> Int -> IO [b]
unmarshallArray CString
fnarr (Int -> IO [DisplayName]) -> IO Int -> IO [DisplayName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CLong -> IO Int
readLong CLong
cnt
CString -> IO ()
xFreeFontNames CString
fnarr
CLong -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CLong
cnt
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return ([DisplayName] -> XResponse
GotFontList [DisplayName]
fns)
XRequest
DefaultRootWindow -> Window -> XResponse
GotDefaultRootWindow (Window -> XResponse) -> IO Window -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> IO Window
xDefaultRootWindow Display
display
XRequest
DefaultVisual ->
Visual -> XResponse
GotVisual (Visual -> XResponse) -> IO Visual -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CVisual -> IO Visual
mkVisual (CVisual -> IO Visual) -> IO CVisual -> IO Visual
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> Int -> IO CVisual
xDefaultVisual Display
d (Int -> IO CVisual) -> IO Int -> IO CVisual
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> IO Int
xDefaultScreen Display
d)
Sync Bool
b -> Display -> Bool -> IO ()
xSync Display
display Bool
b IO () -> IO XResponse -> IO XResponse
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return XResponse
Synced
QueryTextExtents16 FontId
fid DisplayName
s ->
do let n :: Int
n = DisplayName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DisplayName
s
CString
cs <- DisplayName -> Int -> IO CString
forall a. Enum a => [a] -> Int -> IO CString
marshallString16' DisplayName
s Int
n
ints :: [CLong]
ints@[CLong
dir,CLong
ascent,CLong
descent,CLong
overall] <- Int -> IO [CLong]
newLongs Int
4
CXCharStruct
overall <- IO CXCharStruct
forall a. IsPtr a => IO a
newPtr
Display
-> FontId
-> CString
-> Int
-> CLong
-> CLong
-> CLong
-> CXCharStruct
-> IO ()
xQueryTextExtents16 Display
display FontId
fid CString
cs Int
n CLong
dir CLong
ascent CLong
descent CXCharStruct
overall
[Int
asc,Int
desc] <- (CLong -> IO Int) -> [CLong] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CLong -> IO Int
readLong [CLong
ascent,CLong
descent]
CharStruct
ov <- CXCharStruct -> IO CharStruct
mkCharStruct CXCharStruct
overall
[CLong] -> IO ()
forall (t :: * -> *) a. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CLong]
ints
CXCharStruct -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXCharStruct
overall
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (XResponse -> IO XResponse) -> XResponse -> IO XResponse
forall a b. (a -> b) -> a -> b
$ Int -> Int -> CharStruct -> XResponse
TextExtents16Queried Int
asc Int
desc CharStruct
ov
ListFontsWithInfo DisplayName
pattern Int
maxnames ->
[(DisplayName, FontStructList)] -> XResponse
GotFontListWithInfo ([(DisplayName, FontStructList)] -> XResponse)
-> IO [(DisplayName, FontStructList)] -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> DisplayName -> Int -> IO [(DisplayName, FontStructList)]
listFontsWithInfo Display
d DisplayName
pattern Int
maxnames
XRequest
DbeQueryExtension ->
do ints :: [CLong]
ints@[CLong
major,CLong
minor] <- Int -> IO [CLong]
newLongs Int
2
Int
status <- Display -> CLong -> CLong -> IO Int
xdbeQueryExtension Display
display CLong
major CLong
minor
Int
ma <- CLong -> IO Int
readLong CLong
major
Int
mi <- CLong -> IO Int
readLong CLong
minor
[CLong] -> IO ()
forall (t :: * -> *) a. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CLong]
ints
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Int -> XResponse
DbeExtensionQueried Int
status Int
ma Int
mi)
DbeAllocateBackBufferName SwapAction
swapAction ->
DbeBackBufferId -> XResponse
DbeBackBufferNameAllocated (DbeBackBufferId -> XResponse)
-> IO DbeBackBufferId -> IO XResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Window -> SwapAction -> IO DbeBackBufferId
xdbeAllocateBackBufferName Display
d Window
wi SwapAction
swapAction
DbeSwapBuffers SwapAction
swapAction ->
do (CXdbeSwapInfoArray
swapinfo,Int
cnt) <- [(Window, SwapAction)] -> IO (CXdbeSwapInfoArray, Int)
storeSwapAction [(Window
wi,SwapAction
swapAction)]
Int
status <- Display -> CXdbeSwapInfoArray -> Int -> IO Int
xdbeSwapBuffers Display
display CXdbeSwapInfoArray
swapinfo Int
cnt
CXdbeSwapInfoArray -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXdbeSwapInfoArray
swapinfo
XResponse -> IO XResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> XResponse
DbeBuffersSwapped Int
status)
XRequest
_ -> DisplayName -> IO XResponse
forall a. HasCallStack => DisplayName -> a
error (XRequest -> DisplayName
forall a. Show a => a -> DisplayName
notImplemented XRequest
req)
where
createWindow :: Window -> Rect -> IO Window
createWindow Window
parent (Rect (Point Int
x Int
y) (Point Int
w Int
h)) = do
Int
screen <- Display -> IO Int
xDefaultScreen Display
display
Int
blackP <- Display -> Int -> IO Int
xBlackPixel Display
display Int
screen
Int
whiteP <- Display -> Int -> IO Int
xWhitePixel Display
display Int
screen
let border_width :: Int
border_width = Int
0
Window
this <- Display
-> Window
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> IO Window
xCreateSimpleWindow Display
display Window
parent Int
x Int
y Int
w Int
h Int
border_width Int
blackP Int
whiteP
Display -> Window -> DisplayName -> IO ()
xStoreName Display
display Window
this DisplayName
"Fudgets"
Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
this
dcm :: ColormapId -> IO ColormapId
dcm = Display -> ColormapId -> IO ColormapId
dcmap Display
display
setClassHint :: Display -> Window -> String -> String -> IO ()
setClassHint :: Display -> Window -> DisplayName -> DisplayName -> IO ()
setClassHint Display
d Window
w DisplayName
resName DisplayName
resClass =
do CXClassHint
class_hints <- IO CXClassHint
forall a. IsPtr a => IO a
newPtr
CString
rn<-DisplayName -> IO CString
marshallString DisplayName
resName
SET(XClassHint,CString,class_hints,res_name,rn)
CString
rc<-DisplayName -> IO CString
marshallString DisplayName
resClass
SET(XClassHint,CString,class_hints,res_class,rc)
Display -> Window -> CXClassHint -> IO ()
xSetClassHint Display
d Window
w CXClassHint
class_hints
CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
rn
CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
rc
createGC :: Display -> DrawableId -> IO GCId
createGC :: Display -> DrawableId -> IO GCId
createGC Display
d DrawableId
w = Display -> DrawableId -> Bitmask -> CXGCValues -> IO GCId
xCreateGC Display
d DrawableId
w Bitmask
0 CXGCValues
forall a. IsPtr a => a
nullPtr
copyGC :: Display -> GCId -> GCId -> IO ()
copyGC :: Display -> GCId -> GCId -> IO ()
copyGC Display
d GCId
oldgc GCId
gc =
Display -> GCId -> Bitmask -> GCId -> IO ()
xCopyGC Display
d GCId
oldgc Bitmask
8388607 GCId
gc
changeGC :: Display -> GCId -> XGCValuesMask -> IO ()
changeGC Display
d GCId
gc (CXGCValues
gcvals,Bitmask
mask) = Display -> GCId -> Bitmask -> CXGCValues -> IO ()
xChangeGC Display
d GCId
gc Bitmask
mask CXGCValues
gcvals
allocNamedColor :: Display -> String -> ColormapId -> IO (Maybe Color)
allocNamedColor :: Display -> DisplayName -> ColormapId -> IO (Maybe Color)
allocNamedColor Display
d DisplayName
colname ColormapId
cm = do
CXColor
exact <- IO CXColor
forall a. IsPtr a => IO a
newPtr
CXColor
screen <- IO CXColor
forall a. IsPtr a => IO a
newPtr
Int
status <- Display
-> ColormapId -> DisplayName -> CXColor -> CXColor -> IO Int
xAllocNamedColor Display
d ColormapId
cm DisplayName
colname CXColor
screen CXColor
exact
Maybe Color
r <- Int -> CXColor -> IO (Maybe Color)
returnColor Int
status CXColor
screen
CXColor -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXColor
exact
CXColor -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXColor
screen
Maybe Color -> IO (Maybe Color)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Color
r
returnColor :: Int -> CXColor -> IO (Maybe Color)
returnColor Int
status CXColor
c =
if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
0::Int)
then Color -> Maybe Color
forall a. a -> Maybe a
Just (Color -> Maybe Color) -> IO Color -> IO (Maybe Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CXColor -> IO Color
mkColor CXColor
c
else Maybe Color -> IO (Maybe Color)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Color
forall a. Maybe a
Nothing
mkColor :: CXColor -> IO Color
mkColor CXColor
xcol =
Pixel -> RGB -> Color
Color (Pixel -> RGB -> Color) -> (Word -> Pixel) -> Word -> RGB -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Pixel
Pixel
(Word -> RGB -> Color) -> IO Word -> IO (RGB -> Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XColor,Word,xcol,pixel)
IO (RGB -> Color) -> IO RGB -> IO Color
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int -> Int -> RGB
RGB
(Int -> Int -> Int -> RGB) -> IO Int -> IO (Int -> Int -> RGB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XColor,Int,xcol,red)
IO (Int -> Int -> RGB) -> IO Int -> IO (Int -> RGB)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XColor,Int,xcol,green)
IO (Int -> RGB) -> IO Int -> IO RGB
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XColor,Int,xcol,blue)
)
allocColor :: Display -> RGB -> ColormapId -> IO (Maybe Color)
allocColor :: Display -> RGB -> ColormapId -> IO (Maybe Color)
allocColor Display
d RGB
rgb ColormapId
cm = do
CXColor
color <- IO CXColor
newXColor
RGB -> CXColor -> IO ()
setRGB RGB
rgb CXColor
color
Int
status <- Display -> ColormapId -> CXColor -> IO Int
xAllocColor Display
d ColormapId
cm CXColor
color
Maybe Color
r <- Int -> CXColor -> IO (Maybe Color)
returnColor Int
status CXColor
color
CXColor -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXColor
color
Maybe Color -> IO (Maybe Color)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Color
r
setRGB :: RGB -> CXColor -> IO ()
setRGB (RGB Int
red Int
green Int
blue) CXColor
color = do
SET(XColor,Int,color,red,red)
SET(XColor,Int,color,green,green)
SET(XColor,Int,color,blue,blue)
type XGCValuesMask = (CXGCValues,Bitmask)
getGCValues :: GCAttributeList -> IO XGCValuesMask
getGCValues :: GCAttributeList -> IO XGCValuesMask
getGCValues = IO CXGCValues
-> (CXGCValues -> GCAttributes Pixel FontId -> (IO (), Bitmask))
-> GCAttributeList
-> IO XGCValuesMask
forall (m :: * -> *) (t :: * -> *) b a1 p a2.
(Foldable t, Num b, Monad m, Bits b) =>
m a1 -> (a1 -> p -> (m a2, b)) -> t p -> m (a1, b)
getValues IO CXGCValues
forall a. IsPtr a => IO a
newPtr CXGCValues -> GCAttributes Pixel FontId -> (IO (), Bitmask)
forall a a.
(ToC a, ToXID a) =>
CXGCValues -> GCAttributes a a -> (IO (), Bitmask)
getGCValue where
getGCValue :: CXGCValues -> GCAttributes a a -> (IO (), Bitmask)
getGCValue CXGCValues
gcv GCAttributes a a
ga = case GCAttributes a a
ga of
GCFunction GCFunction
f -> (SET(XGCValues,Int,gcv,function,fromEnum f),CWORD32(GCFunction)::Bitmask)
GCForeground a
p -> (SET(XGCValues,Int,gcv,foreground,toC p),CWORD32(GCForeground))
GCBackground a
p -> (SET(XGCValues,Int,gcv,background,toC p),CWORD32(GCBackground))
GCLineWidth Int
w -> (SET(XGCValues,Int,gcv,line_width,w),CWORD32(GCLineWidth))
GCLineStyle GCLineStyle
s -> (SET(XGCValues,Int,gcv,line_style,fromEnum s),CWORD32(GCLineStyle))
GCFont a
f -> (SET(XGCValues,XID,gcv,font,toXID f),CWORD32(GCFont))
GCCapStyle GCCapStyle
s -> (SET(XGCValues,Int,gcv,cap_style,fromEnum s),CWORD32(GCCapStyle))
GCJoinStyle GCJoinStyle
s -> (SET(XGCValues,Int,gcv,join_style,fromEnum s),CWORD32(GCJoinStyle))
GCSubwindowMode GCSubwindowMode
m -> (SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m),CWORD32(GCSubwindowMode))
GCGraphicsExposures Bool
g -> (SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g),CWORD32(GCGraphicsExposures))
GCFillStyle GCFillStyle
f -> (SET(XGCValues,Int,gcv,fill_style,fromEnum f),CWORD32(GCFillStyle))
GCTile PixmapId
p -> (SET(XGCValues,XID,gcv,tile,toXID p),CWORD32(GCTile))
GCStipple PixmapId
p -> (SET(XGCValues,XID,gcv,stipple,toXID p),CWORD32(GCStipple) :: Bitmask)
loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList)
loadQueryFont :: Display -> DisplayName -> IO (Maybe FontStructList)
loadQueryFont Display
d DisplayName
fn = CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList (CXFontStruct -> IO (Maybe FontStructList))
-> IO CXFontStruct -> IO (Maybe FontStructList)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> DisplayName -> IO CXFontStruct
xLoadQueryFont Display
d DisplayName
fn
queryFont :: Display -> FontId -> IO (Maybe FontStructList)
queryFont :: Display -> FontId -> IO (Maybe FontStructList)
queryFont Display
d FontId
fi = CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList (CXFontStruct -> IO (Maybe FontStructList))
-> IO CXFontStruct -> IO (Maybe FontStructList)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> FontId -> IO CXFontStruct
xQueryFont Display
d FontId
fi
listFontsWithInfo :: Display -> FontName -> Int -> IO [(FontName,FontStructList)]
listFontsWithInfo :: Display -> DisplayName -> Int -> IO [(DisplayName, FontStructList)]
listFontsWithInfo Display
d DisplayName
pattern Int
maxnames =
do CInt32
cnt <- IO CInt32
newInt32
CCXFontStruct
fsarrp <- IO CCXFontStruct
newCXFontStruct
CString
fnarr <- Display
-> DisplayName -> Int -> CInt32 -> CCXFontStruct -> IO CString
xListFontsWithInfo Display
d DisplayName
pattern (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxnames) CInt32
cnt CCXFontStruct
fsarrp
Int32
n <- CInt32 -> IO Int32
readInt32 CInt32
cnt
CInt32 -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CInt32
cnt
CXFontStruct
fsarr <- CCXFontStruct -> IO CXFontStruct
forall c h. CVar c h => c -> IO h
readCVar CCXFontStruct
fsarrp
CCXFontStruct -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CCXFontStruct
fsarrp
if CString
fnarrCString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
==CString
nullStr then [(DisplayName, FontStructList)]
-> IO [(DisplayName, FontStructList)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[DisplayName]
fns <- CString -> Int -> IO [DisplayName]
forall prim b c.
(PrimResult prim (IO b), CVar c prim) =>
c -> Int -> IO [b]
unmarshallArray CString
fnarr (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
[FontStructList]
fss <- CXFontStruct -> Int -> IO [FontStructList]
forall c h. CVar c h => c -> Int -> IO [h]
readArray CXFontStruct
fsarr (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
CString -> CXFontStruct -> Int32 -> IO ()
xFreeFontInfo CString
fnarr CXFontStruct
fsarr Int32
n
[(DisplayName, FontStructList)]
-> IO [(DisplayName, FontStructList)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DisplayName]
-> [FontStructList] -> [(DisplayName, FontStructList)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DisplayName]
fns [FontStructList]
fss)
instance CVar CXFontStruct FontStructList
instance Storable FontStructList where
sizeOf :: FontStructList -> Int
sizeOf FontStructList
_ = SIZEOF(XFontStruct)
alignment :: FontStructList -> Int
alignment FontStructList
_ = CXFontStruct -> Int
forall a. Storable a => a -> Int
alignment (CXFontStruct
forall a. HasCallStack => a
undefined::CXFontStruct)
peek :: Addr -> IO FontStructList
peek = CXFontStruct -> IO FontStructList
mkFontStructList' (CXFontStruct -> IO FontStructList)
-> (Addr -> CXFontStruct) -> Addr -> IO FontStructList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> CXFontStruct
CXFontStruct
mkFontStructList :: CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList :: CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList CXFontStruct
fs =
if CXFontStruct
fs CXFontStruct -> CXFontStruct -> Bool
forall a. Eq a => a -> a -> Bool
== Addr -> CXFontStruct
CXFontStruct Addr
nullAddr
then Maybe FontStructList -> IO (Maybe FontStructList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FontStructList
forall a. Maybe a
Nothing
else do FontStructList
fsl <- CXFontStruct -> IO FontStructList
mkFontStructList' CXFontStruct
fs
CString -> CXFontStruct -> Int32 -> IO ()
xFreeFontInfo CString
nullStr CXFontStruct
fs Int32
1
Maybe FontStructList -> IO (Maybe FontStructList)
forall (m :: * -> *) a. Monad m => a -> m a
return (FontStructList -> Maybe FontStructList
forall a. a -> Maybe a
Just FontStructList
fsl)
#if 0
#define DEBUG(cmd) (putStrLn "cmd before">>(cmd)>>= \r->putStrLn "after">>return r)
#else
#define DEBUG(cmd) (cmd)
#endif
mkFontStructList' :: CXFontStruct -> IO FontStructList
mkFontStructList' :: CXFontStruct -> IO FontStructList
mkFontStructList' CXFontStruct
fs =
do
Int
min_char_or_byte2 <- GET(XFontStruct,Int,fs,min_char_or_byte2)
Int
min_byte1 <-GET(XFontStruct,Int,fs,min_byte1)
Int
max_char_or_byte2 <- GET(XFontStruct,Int,fs,max_char_or_byte2)
Int
max_byte1 <-GET(XFontStruct,Int,fs,max_byte1)
Int
n_prop <-GET(XFontStruct,Int,fs,n_properties)
let min :: Int
min = Int
min_char_or_byte2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
min_byte1
max :: Int
max = Int
max_char_or_byte2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
max_byte1
arrsize :: Int
arrsize = (Int
max_char_or_byte2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
min_char_or_byte2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
*
(Int
max_byte1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
min_byte1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
CXCharStruct
per_char <- GET(XFontStruct,HT(XCharStruct),fs,per_char)
Maybe [CharStruct]
elem9 <- if CXCharStruct
per_char CXCharStruct -> CXCharStruct -> Bool
forall a. Eq a => a -> a -> Bool
/= CXCharStruct
forall a. IsPtr a => a
nullPtr
then [CharStruct] -> Maybe [CharStruct]
forall a. a -> Maybe a
Just ([CharStruct] -> Maybe [CharStruct])
-> IO [CharStruct] -> IO (Maybe [CharStruct])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO CharStruct) -> [Int] -> IO [CharStruct]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
i -> INDEX(XCharStruct) per_char i >>= mkCharStruct) Int
[0..arrsize-1]
else Maybe [CharStruct] -> IO (Maybe [CharStruct])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [CharStruct]
forall a. Maybe a
Nothing
CXFontProp
f_prop <- GET(XFontStruct,HT(XFontProp),fs,properties)
[FontProp]
elemprop <- if CXFontProp
f_prop CXFontProp -> CXFontProp -> Bool
forall a. Eq a => a -> a -> Bool
/= CXFontProp
forall a. IsPtr a => a
nullPtr
then (Int -> IO FontProp) -> [Int] -> IO [FontProp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
i -> INDEX(XFontProp) f_prop i >>= mkFontProp) Int
[0..n_prop-1]
else [FontProp] -> IO [FontProp]
forall (m :: * -> *) a. Monad m => a -> m a
return []
FontStructList
fsl <- FontId
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList
forall per_char.
FontId
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe per_char
-> Int
-> Int
-> FontStructF per_char
FontStruct (FontId
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> (XID -> FontId)
-> XID
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XID -> FontId
FontId
(XID
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO XID
-> IO
(FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DEBUG(GET(XFontStruct,XID,fs,fid))
IO
(FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO FontDirection
-> IO
(Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> FontDirection) -> IO Int -> IO FontDirection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> FontDirection
forall a. Enum a => Int -> a
toEnum DEBUG(GET(XFontStruct,Int,fs,direction))
IO
(Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO Char
-> IO
(Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
min)
IO
(Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO Char
-> IO
(Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
max)
IO
(Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO Bool
-> IO
(Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Bool
forall a. Enum a => Int -> a
toEnum DEBUG(GET(XFontStruct,Int,fs,all_chars_exist))
IO
(Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO Char
-> IO
([FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Char,fs,default_char))
IO
([FontProp]
-> CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO [FontProp]
-> IO
(CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FontProp] -> IO [FontProp]
forall (m :: * -> *) a. Monad m => a -> m a
return [FontProp]
elemprop
IO
(CharStruct
-> CharStruct
-> Maybe [CharStruct]
-> Int
-> Int
-> FontStructList)
-> IO CharStruct
-> IO
(CharStruct -> Maybe [CharStruct] -> Int -> Int -> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CXCharStruct -> IO CharStruct
mkCharStruct (CXCharStruct -> IO CharStruct) -> IO CXCharStruct -> IO CharStruct
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)))
IO
(CharStruct -> Maybe [CharStruct] -> Int -> Int -> FontStructList)
-> IO CharStruct
-> IO (Maybe [CharStruct] -> Int -> Int -> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CXCharStruct -> IO CharStruct
mkCharStruct (CXCharStruct -> IO CharStruct) -> IO CXCharStruct -> IO CharStruct
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)))
IO (Maybe [CharStruct] -> Int -> Int -> FontStructList)
-> IO (Maybe [CharStruct]) -> IO (Int -> Int -> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [CharStruct] -> IO (Maybe [CharStruct])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [CharStruct]
elem9
IO (Int -> Int -> FontStructList)
-> IO Int -> IO (Int -> FontStructList)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Int,fs,ascent))
IO (Int -> FontStructList) -> IO Int -> IO FontStructList
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Int,fs,descent))
FontStructList -> IO FontStructList
forall (m :: * -> *) a. Monad m => a -> m a
return FontStructList
fsl
mkFontProp :: CXFontProp -> IO FontProp
mkFontProp :: CXFontProp -> IO FontProp
mkFontProp CXFontProp
fp =
Atom -> Int -> FontProp
FontProp
(Atom -> Int -> FontProp) -> IO Atom -> IO (Int -> FontProp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XFontProp,Atom,fp,name)
IO (Int -> FontProp) -> IO Int -> IO FontProp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XFontProp,Int,fp,card32)
mkCharStruct :: CXCharStruct -> IO CharStruct
mkCharStruct :: CXCharStruct -> IO CharStruct
mkCharStruct CXCharStruct
cs =
Int -> Int -> Int -> Int -> Int -> CharStruct
CharStruct
(Int -> Int -> Int -> Int -> Int -> CharStruct)
-> IO Int -> IO (Int -> Int -> Int -> Int -> CharStruct)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XCharStruct,Int,cs,lbearing)
IO (Int -> Int -> Int -> Int -> CharStruct)
-> IO Int -> IO (Int -> Int -> Int -> CharStruct)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,rbearing)
IO (Int -> Int -> Int -> CharStruct)
-> IO Int -> IO (Int -> Int -> CharStruct)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,width)
IO (Int -> Int -> CharStruct) -> IO Int -> IO (Int -> CharStruct)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,ascent)
IO (Int -> CharStruct) -> IO Int -> IO CharStruct
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,descent)
mkVisual :: CVisual -> IO Visual
mkVisual :: CVisual -> IO Visual
mkVisual CVisual
cv =
VisualID
-> DisplayClass -> Word -> Word -> Word -> Int -> Int -> Visual
Visual
(VisualID
-> DisplayClass -> Word -> Word -> Word -> Int -> Int -> Visual)
-> IO VisualID
-> IO
(DisplayClass -> Word -> Word -> Word -> Int -> Int -> Visual)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(Visual,VisualID,cv,visualid)
IO (DisplayClass -> Word -> Word -> Word -> Int -> Int -> Visual)
-> IO DisplayClass
-> IO (Word -> Word -> Word -> Int -> Int -> Visual)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> DisplayClass) -> IO Int -> IO DisplayClass
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> DisplayClass
forall a. Enum a => Int -> a
toEnum GET(Visual,Int,cv,class)
IO (Word -> Word -> Word -> Int -> Int -> Visual)
-> IO Word -> IO (Word -> Word -> Int -> Int -> Visual)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Word) -> IO Int -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
intToWord GET(Visual,Int,cv,red_mask)
IO (Word -> Word -> Int -> Int -> Visual)
-> IO Word -> IO (Word -> Int -> Int -> Visual)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Word) -> IO Int -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
intToWord GET(Visual,Int,cv,green_mask)
IO (Word -> Int -> Int -> Visual)
-> IO Word -> IO (Int -> Int -> Visual)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Word) -> IO Int -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
intToWord GET(Visual,Int,cv,blue_mask)
IO (Int -> Int -> Visual) -> IO Int -> IO (Int -> Visual)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(Visual,Int,cv,bits_per_rgb)
IO (Int -> Visual) -> IO Int -> IO Visual
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(Visual,Int,cv,map_entries)
storeSwapAction :: [(WindowId,SwapAction)] -> IO (CXdbeSwapInfoArray,Int)
storeSwapAction :: [(Window, SwapAction)] -> IO (CXdbeSwapInfoArray, Int)
storeSwapAction =
(Int -> IO CXdbeSwapInfoArray)
-> (CXdbeSwapInfoArray -> (Int, (Window, SwapAction)) -> IO ())
-> [(Window, SwapAction)]
-> IO (CXdbeSwapInfoArray, Int)
forall (m :: * -> *) a1 a2 b.
Monad m =>
(Int -> m a1) -> (a1 -> (Int, a2) -> m b) -> [a2] -> m (a1, Int)
getArray Int -> IO CXdbeSwapInfoArray
newXdbeSwapInfoArray
(\CXdbeSwapInfoArray
si (Int
i,(Window
wi,SwapAction
sa)) ->
do SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi)
SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa))
translateCoordinates :: Display -> Window -> Window -> IO (Maybe Point)
translateCoordinates Display
display Window
window Window
dstwindow =
do CInt32
dx <- IO CInt32
forall a. IsPtr a => IO a
newPtr
CInt32
dy <- IO CInt32
forall a. IsPtr a => IO a
newPtr
CLong
child <- IO CLong
forall a. IsPtr a => IO a
newPtr
Bool
ok <- Display
-> Window
-> Window
-> Int
-> Int
-> CInt32
-> CInt32
-> CLong
-> IO Bool
xTranslateCoordinates Display
display Window
window Window
dstwindow Int
0 Int
0 CInt32
dx CInt32
dy CLong
child
Maybe Point
p <- if Bool
ok
then Point -> Maybe Point
forall a. a -> Maybe a
Just (Point -> Maybe Point) -> IO Point -> IO (Maybe Point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Point
Point (Int -> Int -> Point) -> IO Int -> IO (Int -> Point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int32 -> Int
forall a. Enum a => a -> Int
fromEnum (Int32 -> Int) -> IO Int32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
dx)
IO (Int -> Point) -> IO Int -> IO Point
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int32 -> Int
forall a. Enum a => a -> Int
fromEnum (Int32 -> Int) -> IO Int32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
dy))
else Maybe Point -> IO (Maybe Point)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
forall a. Maybe a
Nothing
[CInt32] -> IO ()
forall (t :: * -> *) a. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CInt32
dx,CInt32
dy]
CLong -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CLong
child
Maybe Point -> IO (Maybe Point)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
p