{-# 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 = 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

--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 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
	 --xSynchronize d synchronize -- has no effect?!
	 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. */
       -- xSetWMHints display this InputHint True
       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 -- 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"
      CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cfilename -- crash?!!
      --putStrLn "about to read xhot"
      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
      --putStr "xhot =";print x
      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
      --putStrLn "about to free int parameters"
      [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))
   --RmGetStringDatabase str ->
   --RmGetResource rmd s1 s2 ->
   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
                -- putStrLn at_name
                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)
   --QueryTree ->
   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
   --GetGeometry ->
   --GetResource rms ->
   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 -> -- 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
	  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 -- 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 -> 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

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

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
--    _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 -> 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)
    -- _ -> (return (),0)


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
     --putStrLn "About to call xListFontsWithInfo"
     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
     --putStrLn "Returned from call xListFontsWithInfo"
     Int32
n <- CInt32 -> IO Int32
readInt32 CInt32
cnt
     --putStr "Number of fonts: " ; print n
     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
     --putStrLn "After free 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
       --putStrLn "Non-null name array"
       [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)
       --putStrLn "Got name list";print fns
       [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)
       --putStrLn "Got fontstruct list"
       CString -> CXFontStruct -> Int32 -> IO ()
xFreeFontInfo CString
fnarr CXFontStruct
fsarr Int32
n
       --putStrLn "Freed fontinfo, returning"
       [(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 -- just for readArray...
--sizeOf _ = sizeOf (undefined::CXFontStruct) -- Wrong size!!!
  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
           --_casm_ ``XFreeFontInfo(NULL, %0, 1); '' 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 --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 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)
         --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 CXCharStruct -> CXCharStruct -> Bool
forall a. Eq a => a -> a -> Bool
/= CXCharStruct
forall a. IsPtr a => a
nullPtr -- CCONST(NULL) 
       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
     --putStrLn "after elem9"
     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 []
     -- putStrLn $ show elemprop
     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))
     -- putStrLn $ "Returning from mkFontStructList'" ++ (show fsl)
     FontStructList -> IO FontStructList
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
   (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