{-# LANGUAGE CPP #-}
{- Obsolete OPTIONS -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}
--  -optc-I/usr/X11R6/include
module DoXRequest(doXRequest,getGCValues,translateCoordinates) where

--import P_IO_data(Request(..),Response(..))
import Geometry
import Command
import Event
import Xtypes
import Font
--import ResourceIds
import Visual
import HbcWord(intToWord) -- for Visual
import IOUtil(getEnvi)
--import CmdLineEnv(argFlag)

import XCallTypes
import StructFuns
import Xlib
import Marshall
import MyForeign -- debugging
import CString16

--import Ap

{-
#include "newstructfuns.h"
-}

newXID :: IO CXID
newXID = forall a. IsPtr a => IO a
newPtr :: IO CXID
newLong :: IO CLong
newLong = forall a. IsPtr a => IO a
newPtr :: IO CLong
newLongs :: Int -> IO [CLong]
newLongs Int
n = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Int -> a -> [a]
replicate Int
n IO CLong
newLong)
readLong :: CLong -> IO Int
readLong = forall c h. CVar c h => c -> IO h
readCVar :: CLong -> IO Int
newInt32 :: IO CInt32
newInt32 = forall a. IsPtr a => IO a
newPtr :: IO CInt32
newInt32s :: Int -> IO [CInt32]
newInt32s Int
n = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Int -> a -> [a]
replicate Int
n IO CInt32
newInt32)
readInt32 :: CInt32 -> IO Int32
readInt32 = forall c h. CVar c h => c -> IO h
readCVar :: CInt32 -> IO Int32
freePtrs :: t a -> IO ()
freePtrs t a
xs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. HasAddr a => a -> IO ()
freePtr t a
xs

--synchronize = argFlag "synchronize" False

{-
doXRequest req@(display,_,_) =
  do r <- doXRequest' req
     if synchronize && display/=noDisplay then xSync display False else return ()
     return r
-}
{-
doXRequest req@(display,_,_) | display/=noDisplay =
    withLockedDisplay display $ doXRequest' req
doXRequest req = doXRequest' req
-}
doXRequest :: (Display, Window, XRequest) -> IO XResponse
doXRequest (d :: Display
d@Display
display,Window
wi,XRequest
req) =
 case XRequest
req of
   OpenDisplay FontName
optname ->
      do FontName
name <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FontName
optname
		 then case FontName -> Maybe FontName
getEnvi FontName
"DISPLAY" of
		        Just FontName
n -> forall (m :: * -> *) a. Monad m => a -> m a
return FontName
n
	                Maybe FontName
Nothing -> forall a. FontName -> IO a
failu FontName
"DISPLAY variable is not set"
		 else forall (m :: * -> *) a. Monad m => a -> m a
return FontName
optname
         Display
d <- FontName -> IO Display
xOpenDisplay FontName
name
	 --xSynchronize d synchronize -- has no effect?!
	 forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> XResponse
DisplayOpened Display
d)
   CreateSimpleWindow Path
p Rect
r -> Window -> XResponse
WindowCreated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> Rect -> IO Window
createWindow Window
wi Rect
r
   CreateRootWindow Rect
r FontName
resname -> Window -> XResponse
WindowCreated 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 -> FontName -> FontName -> IO ()
setClassHint Display
display Window
this FontName
resname FontName
"Fudgets"
	  /* This is a hack that solves a focus problem with twm.
	     The twm option NoTitleFocus also solves the problem. */
       -- xSetWMHints display this InputHint True
       forall (m :: * -> *) a. Monad m => a -> m a
return Window
this
   CreateGC Drawable
dr GCId
oldgc GCAttributeList
gcattrs -> GCId -> XResponse
GCCreated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
     Window
wi' <- if Window
wi forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else 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 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 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 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
     forall (m :: * -> *) a. Monad m => a -> m a
return GCId
gc
   LoadFont FontName
fn -> FontId -> XResponse
FontLoaded forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontName -> IO FontId
xLoadFont Display
display FontName
fn
   CreateFontCursor Int
shp -> CursorId -> XResponse
CursorCreated 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 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 (forall a. ToC a => a -> Int
toC [EventMask]
evm)
	  Int
grabModeAsync Int
grabModeAsync Window
windowNone CursorId
cursorNone Int
currentTime
   AllocNamedColor ColormapId
cm FontName
cn ->
      Maybe Color -> XResponse
ColorAllocated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Display -> FontName -> ColormapId -> IO (Maybe Color)
allocNamedColor Display
display FontName
cn 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Display -> RGB -> ColormapId -> IO (Maybe Color)
allocColor Display
display RGB
rgb 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
     Int
depth' <- if Int
depth forall a. Eq a => a -> a -> Bool
== Int
copyFromParent
		  then Display -> Int -> IO Int
xDefaultDepth Display
display forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> IO Int
xDefaultScreen Display
display
		  else forall (m :: * -> *) a. Monad m => a -> m a
return Int
depth
     WindowId XID
wi' <- if Window
wi forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else 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 FontName
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 <- FontName -> IO CString
marshallString FontName
filename -- GHC gives faulty code for marshallM?
      --putStrLn "about to call xReadBitmapFile"
      --writeCVar xhot 0
      --putStrLn filename
      --putStrLn =<< unmarshall cfilename
      --print =<< readLong xhot
      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
      --putStrLn "returned from call to xReadBitmapFile"
      forall {a}. HasAddr a => a -> IO ()
freePtr CString
cfilename -- crash?!!
      --putStrLn "about to read xhot"
      Int
x <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
xhot
      --putStr "xhot =";print x
      BitmapReturn
ret <-
        if (Int
r::Int) 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 forall (m :: * -> *) a. Monad m => a -> m a
return BitmapReturn
BitmapBad
      --putStrLn "about to free int parameters"
      forall {t :: * -> *} {a}. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CInt32]
ints
      forall {a}. HasAddr a => a -> IO ()
freePtr CXID
bm
      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 <- FontName -> Int -> IO CString
marshallString' (forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => Int -> a
toEnum [Int]
bytes) (((Int
wforall a. Num a => a -> a -> a
+Int
7) forall a. Integral a => a -> a -> a
`div` Int
8)forall a. Num a => a -> a -> a
*Int
h)
        WindowId XID
wi' <- if Window
wi forall a. Eq a => a -> a -> Bool
== Window
noWindow then Display -> IO Window
xDefaultRootWindow Display
display else forall (m :: * -> *) a. Monad m => a -> m a
return Window
wi
        let cw :: Int32
cw = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
            ch :: Int32
ch = 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
        forall {a}. HasAddr a => a -> IO ()
freePtr CString
cbytes
        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))
   --RmGetStringDatabase str ->
   --RmGetResource rmd s1 s2 ->
   XRequest
TranslateCoordinates ->
     do Window
rootwin <- Display -> IO Window
xDefaultRootWindow Display
display
        Point -> XResponse
CoordinatesTranslated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Point
origin forall a. a -> a
id
          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 FontName
str Bool
b -> Atom -> XResponse
GotAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontName -> Bool -> IO Atom
xInternAtom Display
display FontName
str Bool
b

   GetAtomName Atom
a -> 
     do CString
at_ret <- Display -> Atom -> IO CString
xGetAtomName Display
display Atom
a
        if (CString
at_ret forall a. Eq a => a -> a -> Bool
== CString
nullStr)
           then forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontName -> XResponse
GotAtomName forall a. Maybe a
Nothing)
           else
             do FontName
at_name <- CString -> IO FontName
unmarshallString CString
at_ret
                forall {a}. HasAddr a => a -> IO ()
xFree CString
at_ret
                -- putStrLn at_name
                case (forall (t :: * -> *) a. Foldable t => t a -> Int
length FontName
at_name) of
                   Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontName -> XResponse
GotAtomName forall a. Maybe a
Nothing)
                   Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontName -> XResponse
GotAtomName forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FontName
at_name)

   GetWindowProperty Int
offset Atom
property Bool
delete Atom
req_type ->
     do let length :: Int
length = Int
1000 
	CAtom
actual_type <- forall a. IsPtr a => IO a
newPtr
	CLong
actual_format <- 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 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 <- forall c h. CVar c h => c -> IO h
readCVar CAtom
actual_type
	Int
af <- 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
	FontName
str <- if (Int
af::Int) forall a. Eq a => a -> a -> Bool
== CCONST(None) then return "" else
	    do let got :: Int
got = Int
afforall a. Num a => a -> a -> a
*Int
n forall a. Integral a => a -> a -> a
`div` Int
8
	       CString
cstr <- forall c h. CVar c h => c -> IO h
readCVar CCString
prop_return
	       FontName
str <- CString -> Int -> IO FontName
unmarshallString' CString
cstr Int
got
	       forall {a}. HasAddr a => a -> IO ()
xFree CString
cstr
	       forall (m :: * -> *) a. Monad m => a -> m a
return FontName
str
	forall {a}. HasAddr a => a -> IO ()
freePtr CAtom
actual_type
	forall {a}. HasAddr a => a -> IO ()
freePtr CLong
actual_format
	forall {a}. HasAddr a => a -> IO ()
freePtr CLong
nitems
	forall {a}. HasAddr a => a -> IO ()
freePtr CLong
bytes_after
	forall {a}. HasAddr a => a -> IO ()
freePtr CCString
prop_return
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Atom -> Int -> Int -> Int -> FontName -> XResponse
GotWindowProperty Atom
at Int
af Int
n Int
ba FontName
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
	      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
	     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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)
	     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. FromC a => Int -> a
fromC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CLong -> IO Int
readLong CLong
mask)
     forall {t :: * -> *} {a}. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CLong]
ints
     forall (m :: * -> *) a. Monad m => a -> m a
return XResponse
ret

   QueryFont FontId
fid -> Maybe FontStructList -> XResponse
FontQueried forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontId -> IO (Maybe FontStructList)
queryFont Display
display FontId
fid
   LoadQueryFont FontName
fn -> Maybe FontStructList -> XResponse
FontQueried forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontName -> IO (Maybe FontStructList)
loadQueryFont Display
display FontName
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
      forall {a}. HasAddr a => a -> IO ()
freePtr CXColor
c
      forall (m :: * -> *) a. Monad m => a -> m a
return (Color -> XResponse
ColorQueried Color
r)

   ListFonts FontName
pattern Int
maxnames ->
     do CLong
cnt <- IO CLong
newLong
	CString
fnarr <- Display -> FontName -> Int -> CLong -> IO CString
xListFonts Display
display FontName
pattern Int
maxnames CLong
cnt
	[FontName]
fns <- forall {a} {b} {c}.
(PrimResult a (IO b), CVar c a) =>
c -> Int -> IO [b]
unmarshallArray CString
fnarr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CLong -> IO Int
readLong CLong
cnt
	CString -> IO ()
xFreeFontNames CString
fnarr
	forall {a}. HasAddr a => a -> IO ()
freePtr CLong
cnt
	forall (m :: * -> *) a. Monad m => a -> m a
return ([FontName] -> XResponse
GotFontList [FontName]
fns)
   --QueryTree ->
   XRequest
DefaultRootWindow -> Window -> XResponse
GotDefaultRootWindow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> IO Window
xDefaultRootWindow Display
display
   --GetGeometry ->
   --GetResource rms ->
   XRequest
DefaultVisual ->
     Visual -> XResponse
GotVisual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CVisual -> IO Visual
mkVisual forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> Int -> IO CVisual
xDefaultVisual Display
d 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return XResponse
Synced
   QueryTextExtents16 FontId
fid FontName
s ->
     do let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length FontName
s
	CString
cs <- forall {a}. Enum a => [a] -> Int -> IO CString
marshallString16' FontName
s Int
n
        ints :: [CInt32]
ints@[CInt32
dir,CInt32
ascent,CInt32
descent] <- Int -> IO [CInt32]
newInt32s Int
3
        CXCharStruct
overall <- forall a. IsPtr a => IO a
newPtr
	Display
-> FontId
-> CString
-> Int
-> CInt32
-> CInt32
-> CInt32
-> CXCharStruct
-> IO ()
xQueryTextExtents16 Display
display FontId
fid CString
cs Int
n CInt32
dir CInt32
ascent CInt32
descent CXCharStruct
overall
        [Int32
asc,Int32
desc] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CInt32 -> IO Int32
readInt32 [CInt32
ascent,CInt32
descent]
        CharStruct
ov <- CXCharStruct -> IO CharStruct
mkCharStruct CXCharStruct
overall
        forall {t :: * -> *} {a}. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CInt32]
ints
	forall {a}. HasAddr a => a -> IO ()
freePtr CXCharStruct
overall
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> CharStruct -> XResponse
TextExtents16Queried (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
asc) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
desc) CharStruct
ov
   ListFontsWithInfo FontName
pattern Int
maxnames ->
     [(FontName, FontStructList)] -> XResponse
GotFontListWithInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> FontName -> Int -> IO [(FontName, FontStructList)]
listFontsWithInfo Display
d FontName
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
	forall {t :: * -> *} {a}. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CLong]
ints
	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 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 -> -- applies only to the fudget's own window.
       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
	  forall {a}. HasAddr a => a -> IO ()
freePtr CXdbeSwapInfoArray
swapinfo
	  forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> XResponse
DbeBuffersSwapped Int
status)
   XRequest
_ -> forall a. HasCallStack => FontName -> a
error (forall {a}. Show a => a -> FontName
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 -- should agree with border_width in WindowF.hs !!
    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 -> FontName -> IO ()
xStoreName Display
display Window
this FontName
"Fudgets"
    forall (m :: * -> *) a. Monad m => a -> m a
return Window
this
  dcm :: ColormapId -> IO ColormapId
dcm = Display -> ColormapId -> IO ColormapId
dcmap Display
display

{-
type BorderWidth = Int
type FontShape = Int
-}

setClassHint :: Display -> Window -> String -> String -> IO ()
setClassHint :: Display -> Window -> FontName -> FontName -> IO ()
setClassHint Display
d Window
w FontName
resName FontName
resClass =
  do CXClassHint
class_hints <- forall a. IsPtr a => IO a
newPtr
     CString
rn<-FontName -> IO CString
marshallString FontName
resName
     SET(XClassHint,CString,class_hints,res_name,rn)
     CString
rc<-FontName -> IO CString
marshallString FontName
resClass
     SET(XClassHint,CString,class_hints,res_class,rc)
     Display -> Window -> CXClassHint -> IO ()
xSetClassHint Display
d Window
w CXClassHint
class_hints
     forall {a}. HasAddr a => a -> IO ()
freePtr CString
rn
     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 forall a. IsPtr a => a
nullPtr
--    _casm_ ``%r=XCreateGC(%0,%1,0,NULL);'' d w

copyGC :: Display -> GCId -> GCId -> IO ()
copyGC :: Display -> GCId -> GCId -> IO ()
copyGC Display
d GCId
oldgc GCId
gc = 
  --xCopyGC d oldgc ``(1<<(GCLastBit+1))-1)''gc
  Display -> GCId -> Bitmask -> GCId -> IO ()
xCopyGC Display
d GCId
oldgc Bitmask
8388607  GCId
gc
--   _casm_ ``XCopyGC(%0,%1,(1<<(GCLastBit+1))-1,%2);'' d oldgc 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 -> FontName -> ColormapId -> IO (Maybe Color)
allocNamedColor Display
d FontName
colname ColormapId
cm = do
   CXColor
exact <- forall a. IsPtr a => IO a
newPtr
   CXColor
screen <- forall a. IsPtr a => IO a
newPtr
   Int
status <- Display -> ColormapId -> FontName -> CXColor -> CXColor -> IO Int
xAllocNamedColor Display
d ColormapId
cm FontName
colname CXColor
screen CXColor
exact
   Maybe Color
r <- Int -> CXColor -> IO (Maybe Color)
returnColor Int
status CXColor
screen
   forall {a}. HasAddr a => a -> IO ()
freePtr CXColor
exact
   forall {a}. HasAddr a => a -> IO ()
freePtr CXColor
screen
   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 forall a. Eq a => a -> a -> Bool
/= (Int
0::Int)
    then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CXColor -> IO Color
mkColor CXColor
c
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

mkColor :: CXColor -> IO Color
mkColor CXColor
xcol = 
 Pixel -> RGB -> Color
Color forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Pixel
Pixel
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XColor,Word,xcol,pixel)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int -> Int -> RGB
RGB
	 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XColor,Int,xcol,red)
	 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XColor,Int,xcol,green)
	 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
  forall {a}. HasAddr a => a -> IO ()
freePtr CXColor
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 = forall {m :: * -> *} {t :: * -> *} {b} {a1} {a2} {a3}.
(Foldable t, Num b, Monad m, Bits b) =>
m a1 -> (a1 -> a2 -> (m a3, b)) -> t a2 -> m (a1, b)
getValues forall a. IsPtr a => IO a
newPtr 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)
    -- _ -> (return (),0)


loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList)
loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList)
loadQueryFont Display
d FontName
fn = CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> FontName -> IO CXFontStruct
xLoadQueryFont Display
d FontName
fn

queryFont :: Display -> FontId -> IO (Maybe FontStructList)
queryFont :: Display -> FontId -> IO (Maybe FontStructList)
queryFont Display
d FontId
fi = CXFontStruct -> IO (Maybe FontStructList)
mkFontStructList 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 -> FontName -> Int -> IO [(FontName, FontStructList)]
listFontsWithInfo Display
d FontName
pattern Int
maxnames =
  do CInt32
cnt <- IO CInt32
newInt32
     CCXFontStruct
fsarrp <- IO CCXFontStruct
newCXFontStruct
     --putStrLn "About to call xListFontsWithInfo"
     CString
fnarr <- Display -> FontName -> Int -> CInt32 -> CCXFontStruct -> IO CString
xListFontsWithInfo Display
d FontName
pattern (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxnames) CInt32
cnt CCXFontStruct
fsarrp
     --putStrLn "Returned from call xListFontsWithInfo"
     Int32
n <- CInt32 -> IO Int32
readInt32 CInt32
cnt
     --putStr "Number of fonts: " ; print n
     forall {a}. HasAddr a => a -> IO ()
freePtr CInt32
cnt
     CXFontStruct
fsarr <- forall c h. CVar c h => c -> IO h
readCVar CCXFontStruct
fsarrp
     forall {a}. HasAddr a => a -> IO ()
freePtr CCXFontStruct
fsarrp
     --putStrLn "After free fsarrp"
     if CString
fnarrforall a. Eq a => a -> a -> Bool
==CString
nullStr then forall (m :: * -> *) a. Monad m => a -> m a
return []
      else do
       --putStrLn "Non-null name array"
       [FontName]
fns <- forall {a} {b} {c}.
(PrimResult a (IO b), CVar c a) =>
c -> Int -> IO [b]
unmarshallArray CString
fnarr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
       --putStrLn "Got name list";print fns
       [FontStructList]
fss <- forall c h. CVar c h => c -> Int -> IO [h]
readArray CXFontStruct
fsarr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
       --putStrLn "Got fontstruct list"
       CString -> CXFontStruct -> Int32 -> IO ()
xFreeFontInfo CString
fnarr CXFontStruct
fsarr Int32
n
       --putStrLn "Freed fontinfo, returning"
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. [a] -> [b] -> [(a, b)]
zip [FontName]
fns [FontStructList]
fss)

instance CVar CXFontStruct FontStructList
instance Storable FontStructList where -- just for readArray...
--sizeOf _ = sizeOf (undefined::CXFontStruct) -- Wrong size!!!
  sizeOf :: FontStructList -> Int
sizeOf FontStructList
_ = SIZEOF(XFontStruct)
  alignment :: FontStructList -> Int
alignment FontStructList
_ = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined::CXFontStruct)
  peek :: Addr -> IO FontStructList
peek = CXFontStruct -> IO FontStructList
mkFontStructList' 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 forall a. Eq a => a -> a -> Bool
== Addr -> CXFontStruct
CXFontStruct Addr
nullAddr
   then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
   else do FontStructList
fsl <- CXFontStruct -> IO FontStructList
mkFontStructList' CXFontStruct
fs
           --_casm_ ``XFreeFontInfo(NULL, %0, 1); '' fs
	   CString -> CXFontStruct -> Int32 -> IO ()
xFreeFontInfo CString
nullStr CXFontStruct
fs Int32
1
	   forall (m :: * -> *) a. Monad m => a -> m a
return (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 --putStrLn "Enter mkFontStructList'"
     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)
     -- putStrLn $ "font properties: " ++ (show n_prop)
     --putStrLn "after min max"
     let min :: Int
min = Int
min_char_or_byte2 forall a. Num a => a -> a -> a
+ Int
256forall a. Num a => a -> a -> a
*Int
min_byte1
         max :: Int
max = Int
max_char_or_byte2 forall a. Num a => a -> a -> a
+ Int
256forall a. Num a => a -> a -> a
*Int
max_byte1
         arrsize :: Int
arrsize = (Int
max_char_or_byte2 forall a. Num a => a -> a -> a
- Int
min_char_or_byte2 forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
*
		   (Int
max_byte1 forall a. Num a => a -> a -> a
- Int
min_byte1 forall a. Num a => a -> a -> a
+ Int
1)
         --arrsize = max - min  :: Int -- This is wrong!
     --print ("min max arrsize",min,max,arrsize)
     CXCharStruct
per_char <- GET(XFontStruct,HT(XCharStruct),fs,per_char)
     --putStrLn "after per_char"
     Maybe [CharStruct]
elem9 <- if CXCharStruct
per_char forall a. Eq a => a -> a -> Bool
/= forall a. IsPtr a => a
nullPtr -- CCONST(NULL) 
       then forall a. a -> Maybe a
Just 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 (\Int
i -> INDEX(XCharStruct) per_char i >>= mkCharStruct) Int
[0..arrsize-1] 
       else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     --putStrLn "after elem9"
     CXFontProp
f_prop <- GET(XFontStruct,HT(XFontProp),fs,properties)
     [FontProp]
elemprop <- if CXFontProp
f_prop forall a. Eq a => a -> a -> Bool
/= forall a. IsPtr a => a
nullPtr
       then 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 forall (m :: * -> *) a. Monad m => a -> m a
return []
     -- putStrLn $ show elemprop
     FontStructList
fsl <- forall per_char.
FontId
-> FontDirection
-> Char
-> Char
-> Bool
-> Char
-> [FontProp]
-> CharStruct
-> CharStruct
-> Maybe per_char
-> Int
-> Int
-> FontStructF per_char
FontStruct forall b c a. (b -> c) -> (a -> b) -> a -> c
. XID -> FontId
FontId
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DEBUG(GET(XFontStruct,XID,fs,fid))
	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. Enum a => Int -> a
toEnum DEBUG(GET(XFontStruct,Int,fs,direction))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => Int -> a
toEnum Int
min)
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => Int -> a
toEnum Int
max)
	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. Enum a => Int -> a
toEnum DEBUG(GET(XFontStruct,Int,fs,all_chars_exist))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Char,fs,default_char))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return [FontProp]
elemprop
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CXCharStruct -> IO CharStruct
mkCharStruct forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CXCharStruct -> IO CharStruct
mkCharStruct forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [CharStruct]
elem9
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Int,fs,ascent))
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DEBUG(GET(XFontStruct,Int,fs,descent))
     -- putStrLn $ "Returning from mkFontStructList'" ++ (show fsl)
     forall (m :: * -> *) a. Monad m => a -> m a
return FontStructList
fsl

-- Intermediate data for FontProp, containing just two integers:
-- atom values will (hopefully) be retrieved lazily.

mkFontProp :: CXFontProp -> IO FontProp

mkFontProp :: CXFontProp -> IO FontProp
mkFontProp CXFontProp
fp = 
  Atom -> Int -> FontProp
FontProp
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XFontProp,Atom,fp,name)
  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
     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(XCharStruct,Int,cs,lbearing)
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,rbearing)
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,width)
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(XCharStruct,Int,cs,ascent)
     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
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GET(Visual,VisualID,cv,visualid)
   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. Enum a => Int -> a
toEnum GET(Visual,Int,cv,class)
   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 -> Word
intToWord GET(Visual,Int,cv,red_mask)
   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 -> Word
intToWord GET(Visual,Int,cv,green_mask)
   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 -> Word
intToWord GET(Visual,Int,cv,blue_mask)
   forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GET(Visual,Int,cv,bits_per_rgb)
   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 =
  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 <- forall a. IsPtr a => IO a
newPtr
     CInt32
dy <- forall a. IsPtr a => IO a
newPtr
     CLong
child <- 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 forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Point
Point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Enum a => a -> Int
fromEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
dx)
                               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Enum a => a -> Int
fromEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt32 -> IO Int32
readInt32 CInt32
dy))
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     forall {t :: * -> *} {a}. (Foldable t, HasAddr a) => t a -> IO ()
freePtrs [CInt32
dx,CInt32
dy]
     forall {a}. HasAddr a => a -> IO ()
freePtr CLong
child
     forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
p