{-# LANGUAGE CPP #-}
{- unused options -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}
-- -O
module DoXCommand(doXCommand) where

import Command
import Event
import Geometry
import Xtypes
--import Font
--import ResourceIds
import DrawTypes
import HbcUtils(chopList)

import DoXRequest(getGCValues,translateCoordinates)
import XCallTypes
import StructFuns
import Xlib
import Marshall
import MyForeign
--import CCall
import CString16

import System.IO(hPutStr,hPutStrLn,stderr) -- for error reporting

import PackedString(lengthPS,unpackPS)
--import Word(Word32)
import Data.Bits

--import IO(hFlush,stdout) -- debugging

default (Int)

{-
#include "newstructfuns.h"
-}
-- For debugging only:
{-
doXCommand req@(d,_,_) =
  do r <- doXCommand' req
   --hFlush stdout
     xSync d False
     return r
--}
--doXCommand cmd@(display,_,_) = withLockedDisplay display $ doXCommand' cmd

doXCommand :: (Display, Window, XCommand) -> IO ()
doXCommand :: (Display, Window, XCommand) -> IO ()
doXCommand (Display
d,Window
w,XCommand
req) =
  case XCommand
req of
   CloseDisplay Display
d -> Display -> IO ()
xCloseDisplay Display
d
   XCommand
DestroyWindow -> Display -> Window -> IO ()
xDestroyWindow Display
d Window
w
   XCommand
MapRaised -> Display -> Window -> IO ()
xMapRaised Display
d Window
w
   XCommand
LowerWindow -> Display -> Window -> IO ()
xLowerWindow Display
d Window
w
   XCommand
UnmapWindow -> Display -> Window -> IO ()
xUnmapWindow Display
d Window
w
   XCommand
ClearWindow -> Display -> Window -> IO ()
xClearWindow Display
d Window
w
   StoreName String
s -> Display -> Window -> String -> IO ()
xStoreName Display
d Window
w String
s
   FreeGC GCId
gc -> Display -> GCId -> IO ()
xFreeGC Display
d GCId
gc
   XCommand
UngrabPointer -> Display -> Time -> IO ()
xUngrabPointer Display
d Time
currentTime
   XCommand
Flush -> Display -> IO ()
xFlush Display
d
   ClearArea (Rect (Point Time
x Time
y) (Point Time
wi Time
he)) Bool
exposures ->
      Display -> Window -> Time -> Time -> Time -> Time -> Bool -> IO ()
xClearArea Display
d Window
w Time
x Time
y Time
wi Time
he Bool
exposures
   GrabButton Bool
oe Button
button ModState
ms [EventMask]
evm ->
      Display
-> Time
-> Time
-> Window
-> Bool
-> Time
-> Time
-> Time
-> Window
-> CursorId
-> IO ()
xGrabButton Display
d (Button -> Time
forall a. ToC a => a -> Time
toC Button
button) Time
anyModifier Window
w Bool
oe ([EventMask] -> Time
forall a. ToC a => a -> Time
toC [EventMask]
evm) Time
grabModeAsync Time
grabModeAsync Window
windowNone  CursorId
cursorNone
   UngrabButton Button
b ModState
ms ->
     --_casm_ ``XUngrabButton(%0,%1,AnyModifier,%2);'' d (toC b) w
     Display -> Time -> Time -> Window -> IO ()
xUngrabButton Display
d (Button -> Time
forall a. ToC a => a -> Time
toC Button
b) Time
anyModifier Window
w
   FreePixmap PixmapId
p -> Display -> PixmapId -> IO ()
xFreePixmap Display
d PixmapId
p
   Draw Drawable
drawable GCId
gc DrawCommand
cmd -> DrawableId -> GCId -> DrawCommand -> IO ()
doDrawCommand (Drawable -> DrawableId
getdr Drawable
drawable) GCId
gc DrawCommand
cmd
   DrawMany Drawable
drawable [(GCId, [DrawCommand])]
gccmds -> ((GCId, [DrawCommand]) -> IO ())
-> [(GCId, [DrawCommand])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GCId, [DrawCommand]) -> IO ()
forall (t :: * -> *). Foldable t => (GCId, t DrawCommand) -> IO ()
doDrawMany [(GCId, [DrawCommand])]
gccmds
      where
        dr :: DrawableId
dr = Drawable -> DrawableId
getdr Drawable
drawable
	doDrawMany :: (GCId, t DrawCommand) -> IO ()
doDrawMany (GCId
gc,t DrawCommand
cmds) = (DrawCommand -> IO ()) -> t DrawCommand -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DrawableId -> GCId -> DrawCommand -> IO ()
doDrawCommand DrawableId
dr GCId
gc) t DrawCommand
cmds
   ChangeGC GCId
gc GCAttributeList
gcattrs -> do
     (CXGCValues
gcvals,Bitmask
mask) <- GCAttributeList -> IO (CXGCValues, Bitmask)
getGCValues GCAttributeList
gcattrs
     Display -> GCId -> Bitmask -> CXGCValues -> IO ()
xChangeGC Display
d GCId
gc Bitmask
mask CXGCValues
gcvals
   ChangeWindowAttributes [WindowAttributes]
was -> do
     (CXSetWindowAttributes
attrs,Bitmask
mask) <- [WindowAttributes] -> IO (CXSetWindowAttributes, Bitmask)
getWindowAttributes [WindowAttributes]
was
     --putStr "CWA mask ";print mask
     Display -> Window -> Bitmask -> CXSetWindowAttributes -> IO ()
xChangeWindowAttributes Display
d Window
w Bitmask
mask CXSetWindowAttributes
attrs
   ConfigureWindow [WindowChanges]
wc -> do
     (CXWindowChanges
chgs,Bitmask
mask) <- [WindowChanges] -> IO (CXWindowChanges, Bitmask)
getWindowChanges [WindowChanges]
wc
     Display -> Window -> Bitmask -> CXWindowChanges -> IO ()
xConfigureWindow Display
d Window
w Bitmask
mask CXWindowChanges
chgs
   SetNormalHints (Point Time
x Time
y) -> do
      CXSizeHints
h <- IO CXSizeHints
newXSizeHints 
      SET(XSizeHints,Int,h,x,x)
      SET(XSizeHints,Int,h,y,y)
      SET(XSizeHints,Int,h,flags,CCONST(USPosition)::Int)
      Display -> Window -> CXSizeHints -> IO ()
xSetNormalHints Display
d Window
w CXSizeHints
h
      CXSizeHints -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXSizeHints
h
   SetWMHints Bool
i -> do
      CXWMHints
h <- IO CXWMHints
newXWMHints
      SET(XWMHints,Int,h,flags,CCONST(InputHint)::Int)
      SET(XWMHints,Int,h,input,toC i)
      Display -> Window -> CXWMHints -> IO ()
xSetWMHints Display
d Window
w CXWMHints
h
      CXWMHints -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXWMHints
h
   ShapeCombineMask ShapeKind
kind (Point Time
x Time
y) PixmapId
p ShapeOperation
op ->
     Display
-> Window
-> ShapeKind
-> Time
-> Time
-> PixmapId
-> ShapeOperation
-> IO ()
xShapeCombineMask Display
d Window
w ShapeKind
kind Time
x Time
y PixmapId
p ShapeOperation
op
   ShapeCombineRectangles ShapeKind
kind (Point Time
x Time
y) [Rect]
rs ShapeOperation
op Ordering'
ord -> do
      (CXRectangle
rsa,Time
size) <- [Rect] -> IO (CXRectangle, Time)
storeRectangles [Rect]
rs
      Display
-> Window
-> ShapeKind
-> Time
-> Time
-> CXRectangle
-> Time
-> ShapeOperation
-> Ordering'
-> IO ()
xShapeCombineRectangles Display
d Window
w ShapeKind
kind Time
x Time
y CXRectangle
rsa Time
size ShapeOperation
op Ordering'
ord
      CXRectangle -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXRectangle
rsa
   ShapeCombineShape ShapeKind
dst (Point Time
x Time
y)  PixmapId
p ShapeKind
src ShapeOperation
op ->
       Display
-> Window
-> ShapeKind
-> Time
-> Time
-> PixmapId
-> ShapeKind
-> ShapeOperation
-> IO ()
xShapeCombineShape Display
d Window
w ShapeKind
dst Time
x Time
y PixmapId
p ShapeKind
src ShapeOperation
op
   --RmDestroyDatabase RmDatabase |
   --RmCombineDatabase RmDatabase RmDatabase Bool |
   --RmPutLineResource RmDatabase String |
   SetWMProtocols [Atom]
atoms -> Display -> Window -> [Atom] -> Time -> IO ()
xSetWMProtocols Display
d Window
w [Atom]
atoms ([Atom] -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length [Atom]
atoms)
   SendEvent Window
dst Bool
propagate [EventMask]
evm XEvent
e -> do
     CXEvent
xe <- Window -> XEvent -> IO CXEvent
getEvent Window
dst XEvent
e
     Time
status <- Display -> Window -> Bool -> Bitmask -> CXEvent -> IO Time
xSendEvent Display
d Window
dst Bool
propagate (Time -> Bitmask
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Time -> Bitmask) -> Time -> Bitmask
forall a b. (a -> b) -> a -> b
$ [EventMask] -> Time
forall a. ToC a => a -> Time
toC [EventMask]
evm) CXEvent
xe
     () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   SetSelectionOwner Bool
getit Atom
sel ->
     Display -> Atom -> Window -> Time -> IO ()
xSetSelectionOwner Display
d Atom
sel (if Bool
getit then Window
w else Window
windowNone)  Time
currentTime
   ConvertSelection  (Selection Atom
s Atom
t Atom
p) ->
     Display -> Atom -> Atom -> Atom -> Window -> Time -> IO ()
xConvertSelection Display
d Atom
s Atom
t Atom
p Window
w Time
currentTime
   ChangeProperty Window
w Atom
p Atom
t form :: Time
form@Time
8 PropertyMode
mode String
s -> -- !!
     Display
-> Window
-> Atom
-> Atom
-> Time
-> PropertyMode
-> String
-> Time
-> IO ()
xChangeProperty Display
d Window
w Atom
p Atom
t Time
form PropertyMode
mode String
s (String -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length String
s)
   FreeColors ColormapId
cm [Pixel]
pixls Pixel
planes ->
     do ColormapId
cmid <- Display -> ColormapId -> IO ColormapId
dcmap Display
d ColormapId
cm
	(CPixelArray
pxarr,Time
size) <- [Time] -> IO (CPixelArray, Time)
forall a1 a2. (IsPtr a1, CVar a1 a2) => [a2] -> IO (a1, Time)
toArray [Word -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p|Pixel Word
p<-[Pixel]
pixls] -- hmm
	Display -> ColormapId -> CPixelArray -> Time -> Pixel -> IO ()
xFreeColors Display
d ColormapId
cmid CPixelArray
pxarr Time
size Pixel
planes
   ReparentWindow Window
newParent0 ->
     do Window
newParent <- if Window
newParent0Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
==Window
rootWindow
                     then Display -> IO Window
xDefaultRootWindow Display
d
                     else Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
newParent0
        Maybe Point
mp <- Display -> Window -> Window -> IO (Maybe Point)
translateCoordinates Display
d Window
w Window
newParent
        case Maybe Point
mp of
          Maybe Point
Nothing -> Handle -> String -> IO ()
hPutStr Handle
stderr String
"XTranslateCoordinates: windows on different screens!\n"
          Just (Point Time
x Time
y) -> Display -> Window -> Window -> Time -> Time -> IO ()
xReparentWindow Display
d Window
w Window
newParent Time
x Time
y
   --WarpPointer Point |
   SetRegion GCId
gc Rect
r -> -- !!! modifies a GC -- cache problems!
     do (CXRectangle
rsa,Time
_) <- [Rect] -> IO (CXRectangle, Time)
storeRectangles [Rect
r]
	Region
r <- IO Region
xCreateRegion
	CXRectangle -> Region -> Region -> IO ()
xUnionRectWithRegion CXRectangle
rsa Region
r Region
r
	Display -> GCId -> Region -> IO ()
xSetRegion Display
d GCId
gc Region
r
	Region -> IO ()
xDestroyRegion Region
r
	CXRectangle -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXRectangle
rsa
   --AddToSaveSet |
   --RemoveFromSaveSet 
   Bell Time
n -> Display -> Time -> IO ()
xBell Display
d Time
n

   XCommand
_ -> Handle -> String -> IO ()
hPutStr Handle
stderr (XCommand -> String
forall a. Show a => a -> String
notImplemented XCommand
req)
 where getdr :: Drawable -> DrawableId
getdr = Window -> Drawable -> DrawableId
getdrawable Window
w

       doDrawCommand :: DrawableId -> GCId -> DrawCommand -> IO ()
doDrawCommand DrawableId
drw GCId
gc DrawCommand
cmd = case DrawCommand
cmd of
	  DrawLine (Line (Point Time
x1 Time
y1) (Point Time
x2 Time
y2)) -> 
	    Display
-> DrawableId -> GCId -> Time -> Time -> Time -> Time -> IO ()
xDrawLine Display
d DrawableId
drw GCId
gc Time
x1 Time
y1 Time
x2 Time
y2
	  DrawImageString (Point Time
x Time
y) String
s ->
	    Display
-> DrawableId -> GCId -> Time -> Time -> String -> Time -> IO ()
xDrawImageString Display
d DrawableId
drw GCId
gc Time
x Time
y String
s (String -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length String
s)
	  DrawString (Point Time
x Time
y) String
s ->
	    Display
-> DrawableId -> GCId -> Time -> Time -> String -> Time -> IO ()
xDrawString Display
d DrawableId
drw GCId
gc Time
x Time
y String
s (String -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length String
s)
	  DrawImageString16 (Point Time
x Time
y) String
s ->
	    do let n :: Time
n = String -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length String
s
	       CString
cs <- String -> Time -> IO CString
forall a. Enum a => [a] -> Time -> IO CString
marshallString16' String
s Time
n
	       Display
-> DrawableId -> GCId -> Time -> Time -> CString -> Time -> IO ()
xDrawImageString16 Display
d DrawableId
drw GCId
gc Time
x Time
y CString
cs Time
n
	  DrawString16 (Point Time
x Time
y) String
s ->
	    do let n :: Time
n = String -> Time
forall (t :: * -> *) a. Foldable t => t a -> Time
length String
s
	       CString
cs <- String -> Time -> IO CString
forall a. Enum a => [a] -> Time -> IO CString
marshallString16' String
s Time
n
	       Display
-> DrawableId -> GCId -> Time -> Time -> CString -> Time -> IO ()
xDrawString16 Display
d DrawableId
drw GCId
gc Time
x Time
y CString
cs Time
n
	  DrawRectangle (Rect (Point Time
x1 Time
y1) (Point Time
x2 Time
y2)) ->
            Display
-> DrawableId -> GCId -> Time -> Time -> Time -> Time -> IO ()
xDrawRectangle Display
d DrawableId
drw GCId
gc Time
x1 Time
y1 Time
x2 Time
y2
	  FillRectangle (Rect (Point Time
x1 Time
y1) (Point Time
x2 Time
y2)) ->
            Display
-> DrawableId -> GCId -> Time -> Time -> Time -> Time -> IO ()
xFillRectangle Display
d DrawableId
drw GCId
gc Time
x1 Time
y1 Time
x2 Time
y2
	  FillPolygon Shape
shape CoordMode
coordmode [Point]
ps -> do
	      (CXPoint
xpoints,Time
size) <- [Point] -> IO (CXPoint, Time)
storePoints [Point]
ps
	      Display
-> DrawableId
-> GCId
-> CXPoint
-> Time
-> Shape
-> CoordMode
-> IO ()
xFillPolygon Display
d DrawableId
drw GCId
gc CXPoint
xpoints Time
size Shape
shape CoordMode
coordmode
	      CXPoint -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXPoint
xpoints
	  DrawLines CoordMode
coordmode [Point]
ps -> do
	      (CXPoint
xpoints,Time
size) <- [Point] -> IO (CXPoint, Time)
storePoints [Point]
ps
	      Display
-> DrawableId -> GCId -> CXPoint -> Time -> CoordMode -> IO ()
xDrawLines Display
d DrawableId
drw GCId
gc CXPoint
xpoints Time
size CoordMode
coordmode
	      CXPoint -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CXPoint
xpoints
	  DrawArc (Rect (Point Time
x Time
y) (Point Time
wi Time
he)) Time
a1 Time
a2 ->
	      Display
-> DrawableId
-> GCId
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> IO ()
xDrawArc Display
d DrawableId
drw GCId
gc (Time -> Int32
f Time
x) (Time -> Int32
f Time
y) (Time -> Int32
f Time
wi) (Time -> Int32
f Time
he) (Time -> Int32
f Time
a1) (Time -> Int32
f Time
a2)
            where f :: Time -> Int32
f = Time -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  FillArc (Rect (Point Time
x Time
y) (Point Time
wi Time
he)) Time
a1 Time
a2 ->
	      Display
-> DrawableId
-> GCId
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> IO ()
xFillArc Display
d DrawableId
drw GCId
gc (Time -> Int32
f Time
x) (Time -> Int32
f Time
y) (Time -> Int32
f Time
wi) (Time -> Int32
f Time
he) (Time -> Int32
f Time
a1) (Time -> Int32
f Time
a2)
            where f :: Time -> Int32
f = Time -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  CopyArea Drawable
src (Rect (Point Time
srcx Time
srcy) (Point Time
wi Time
he))
		       (Point Time
dstx Time
dsty) ->
	    Display
-> DrawableId
-> DrawableId
-> GCId
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> IO ()
xCopyArea Display
d (Drawable -> DrawableId
getdr Drawable
src) DrawableId
drw GCId
gc (Time -> Int32
i32 Time
srcx) (Time -> Int32
i32 Time
srcy) (Time -> Int32
u32 Time
wi) (Time -> Int32
u32 Time
he) (Time -> Int32
i32 Time
dstx) (Time -> Int32
i32 Time
dsty)
	  CopyPlane Drawable
src (Rect (Point Time
srcx Time
srcy) (Point Time
wi Time
he)) 
			(Point Time
dstx Time
dsty) Time
plane ->
            --print (gc,drw,cmd) >>
	    Display
-> DrawableId
-> DrawableId
-> GCId
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Word
-> IO ()
xCopyPlane Display
d (Drawable -> DrawableId
getdr Drawable
src)
		       DrawableId
drw GCId
gc (Time -> Int32
f Time
srcx) (Time -> Int32
f Time
srcy) (Time -> Int32
f Time
wi) (Time -> Int32
f Time
he)
                       (Time -> Int32
f Time
dstx) (Time -> Int32
f Time
dsty) (Word -> Time -> Word
forall a. Bits a => a -> Time -> a
shiftL Word
1 Time
plane)
            -- >>putStrLn "done"
            where f :: Time -> Int32
f = Time -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  DrawPoint (Point Time
x Time
y) -> Display -> DrawableId -> GCId -> Time -> Time -> IO ()
xDrawPoint Display
d DrawableId
drw GCId
gc Time
x Time
y
	  CreatePutImage Rect
rect ImageFormat
format [Pixel]
pixels -> DrawableId -> GCId -> Rect -> ImageFormat -> [Pixel] -> IO ()
createPutImage DrawableId
drw GCId
gc Rect
rect ImageFormat
format [Pixel]
pixels
	  DrawImageStringPS (Point Time
x Time
y) PackedString
s ->
	    Display
-> DrawableId -> GCId -> Time -> Time -> String -> Time -> IO ()
xDrawImageString Display
d DrawableId
drw GCId
gc Time
x Time
y (PackedString -> String
unpackPS PackedString
s) (PackedString -> Time
lengthPS PackedString
s) -- !!
	  DrawStringPS (Point Time
x Time
y) PackedString
s ->
	    Display
-> DrawableId -> GCId -> Time -> Time -> String -> Time -> IO ()
xDrawString Display
d DrawableId
drw GCId
gc Time
x Time
y (PackedString -> String
unpackPS PackedString
s) (PackedString -> Time
lengthPS PackedString
s) -- !!
          DrawCommand
_ -> Handle -> String -> IO ()
hPutStr Handle
stderr (DrawCommand -> String
forall a. Show a => a -> String
notImplemented DrawCommand
cmd)

       createPutImage :: DrawableId -> GCId -> Rect -> ImageFormat -> [Pixel] -> IO ()
createPutImage DrawableId
drw GCId
gc rect :: Rect
rect@(Rect (Point Time
x Time
y) (Point Time
w Time
h)) (ImageFormat Time
format) [Pixel]
pixels =
        do --hPutStrLn stderr $ "Entering createPutImage "++show rect
	   Time
screen <- Display -> IO Time
xDefaultScreen Display
d
	   Time
depth <- Display -> Time -> IO Time
xDefaultDepth Display
d Time
screen
	   Time
bpp <- Display -> Time -> IO Time
default_bpp Display
d Time
depth
	   --hPutStrLn stderr ("bpp="++show bpp)
	   let byte_depth :: Time
byte_depth = (Time
depthTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
7) Time -> Time -> Time
forall a. Integral a => a -> a -> a
`div` Time
8
	       bytes_pp :: Time
bytes_pp = (Time
bppTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
7) Time -> Time -> Time
forall a. Integral a => a -> a -> a
`div` Time
8
	       bitmap_pad :: Time
bitmap_pad = Time
32
	       bytes_per_line :: Time
bytes_per_line = ((Time
wTime -> Time -> Time
forall a. Num a => a -> a -> a
*Time
bytes_ppTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
3) Time -> Time -> Time
forall a. Integral a => a -> a -> a
`div` Time
4) Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
4 -- assumes bitmap_pad == 32
	       nullCount :: Time
nullCount = Time
bytes_per_line Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
wTime -> Time -> Time
forall a. Num a => a -> a -> a
*Time
bytes_pp
	       size :: Time
size= Time
wTime -> Time -> Time
forall a. Num a => a -> a -> a
*Time
h
	       pxlines :: [[Pixel]]
pxlines = ([Pixel] -> ([Pixel], [Pixel])) -> [Pixel] -> [[Pixel]]
forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chopList (Time -> [Pixel] -> ([Pixel], [Pixel])
forall a. Time -> [a] -> ([a], [a])
splitAt Time
w) [Pixel]
pixels
	   ByteOrder
byteOrder <- Display -> IO ByteOrder
xImageByteOrder Display
d
#if 1
	   -- High level solution, not fast enough:
	   let pxlToBytes :: Pixel -> String
pxlToBytes = if ByteOrder
byteOrderByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
==ByteOrder
LSBFirst then Pixel -> String
lsb else Pixel -> String
msb
	       msb :: Pixel -> String
msb (Pixel Word
p) = String
pad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse (Time -> Time -> String
forall t a. (Eq t, Num t, Enum a) => t -> Time -> [a]
lsb' Time
byte_depth (Word -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p))
	       pad :: String
pad = Time -> Char -> String
forall a. Time -> a -> [a]
replicate (Time
bytes_ppTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
byte_depth) Char
'\0'
	       lsb :: Pixel -> String
lsb (Pixel Word
p) = Time -> Time -> String
forall t a. (Eq t, Num t, Enum a) => t -> Time -> [a]
lsb' Time
byte_depth (Word -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pad
	       lsb' :: t -> Time -> [a]
lsb' t
0 Time
_ = []
	       lsb' t
n Time
p = Time -> a
forall a. Enum a => Time -> a
toEnum (Time
p Time -> Time -> Time
forall a. Integral a => a -> a -> a
`mod` Time
256) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> Time -> [a]
lsb' (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Time
p Time -> Time -> Time
forall a. Integral a => a -> a -> a
`div` Time
256)
	       linePad :: String
linePad = Time -> Char -> String
forall a. Time -> a -> [a]
replicate Time
nullCount Char
'\0'
	       byteLine :: t Pixel -> String
byteLine t Pixel
pxls = (Pixel -> String) -> t Pixel -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pixel -> String
pxlToBytes t Pixel
pxls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
linePad
	       bytes :: String
bytes = ([Pixel] -> String) -> [[Pixel]] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Pixel] -> String
forall (t :: * -> *). Foldable t => t Pixel -> String
byteLine [[Pixel]]
pxlines
	       --imgdata = psToByteArray (packString bytes)
           --hPutStrLn stderr "Checkpoint 1 in createPutImage"
           --hPutStrLn stderr $ "nullCount="++show nullCount
#else
	   -- Low level solution, faster, but still not fast enough:
	   imgdata <- stToIO $ newCharArray (1,bytes_per_line*h)
	   let convImage = convLines 0 pixels
	       convLines y pixels | y>=h = return ()
	                          | otherwise =
	         do pixels' <- convLine y pixels
		    convLines (y+1) pixels'
	       convLine y pixels = convPixels (y*bytes_per_line) 0 pixels
	       convPixels i x pixels | x>=w = return pixels
	       convPixels i x (Pixel p:pixels) =
		 do convPixel i p
		    convPixels (i+bytes_pp) (x+1) pixels
	       convPixel =
	         if byteOrder==(CCONST(LSBFirst)::Int)
		 then convPixelLSB
		 else convPixelMSB
	       convPixelLSB i p =
	           pixelBytes i p byte_depth
		   -- pad with zeros?
	         where
		   pixelBytes i p 0 = return ()
		   pixelBytes i p n =
		     do SINDEX(char,imgdata,i::Int,p::Int)
		        pixelBytes (i+1) (p `div` 256) (n-1)
	       convPixelMSB i p =
	           do let i' = i+bytes_pp-1
		      -- pad with zeros?
		      pixelBytes i' p bytes_pp
	         where
		   pixelBytes i p 0 = return ()
		   pixelBytes i p n =
		     do SINDEX(char,imgdata,i::Int,p::Int)
		        pixelBytes (i-1) (p `div` 256) (n-1)
		 
	    in convImage
#endif
	   CVisual
dv <- Display -> Time -> IO CVisual
xDefaultVisual Display
d Time
screen
           --hPutStrLn stderr "Checkpoint 2 in createPutImage"
           --if bytes==bytes then return () else undefined
           --hPutStrLn stderr "Checkpoint 3 in createPutImage"
	   CString
cbytes <- String -> Time -> IO CString
marshallString' String
bytes (Time
hTime -> Time -> Time
forall a. Num a => a -> a -> a
*Time
bytes_per_line)
	   CXImage
image <- Display
-> CVisual
-> Time
-> Time
-> Time
-> CString
-> Time
-> Time
-> Time
-> Time
-> IO CXImage
xCreateImage Display
d CVisual
dv Time
depth Time
format Time
0 CString
cbytes Time
w Time
h Time
bitmap_pad Time
bytes_per_line
           --hPutStrLn stderr $ "Checkpoint 4 in createPutImage "++show image
	   Display
-> DrawableId
-> GCId
-> CXImage
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> IO ()
xPutImage Display
d DrawableId
drw GCId
gc CXImage
image Int32
0 Int32
0 (Time -> Int32
i32 Time
x) (Time -> Int32
i32 Time
y) (Time -> Int32
i32 Time
w) (Time -> Int32
i32 Time
h)
--	   ioCmd $ _casm_ ``((XImage *)(%0))->data=NULL;XDestroyImage((XImage *)%0);'' image
	   --_casm_ ``((XImage *)(%0))->data=NULL;'' image
           --hPutStrLn stderr "Checkpoint 5 in createPutImage"
	   CXImage -> Addr -> IO ()
setXImage_data CXImage
image Addr
nullAddr
           --hPutStrLn stderr "Checkpoint 6 in createPutImage"
	   CXImage -> IO ()
xDestroyImage CXImage
image
           --hPutStrLn stderr "Checkpoint 7 in createPutImage"
	   CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cbytes
           --hPutStrLn stderr "Returning from createPutImage"
{-
       default_bpp :: Display -> Int -> IO Int
       default_bpp (Display display) depth =
         _casm_
	    ``{int i,cnt,bpp;
	       XPixmapFormatValues *ps=XListPixmapFormats(%0,&cnt);
	       bpp=%1; /* Hmm. Something is wrong if depth isn't found. */
	       for(i=0;i<cnt;i++)
	         if(ps[i].depth==%1) {
		   bpp=ps[i].bits_per_pixel;
		   break;
		 }
	       XFree(ps);
	       %r=bpp;}'' display depth
-}
foreign import ccall "asyncinput.h" default_bpp :: Display -> Int -> IO Int
foreign import ccall "asyncinput.h" setXImage_data :: CXImage -> Addr -> IO ()

i32 :: Int->Int32
i32 :: Time -> Int32
i32 = Time -> Int32
forall a. Enum a => Time -> a
toEnum
u32 :: Int->Unsigned32
u32 :: Time -> Int32
u32 = Time -> Int32
forall a. Enum a => Time -> a
toEnum

getWindowAttributes :: [WindowAttributes] -> IO (CXSetWindowAttributes, Bitmask)
getWindowAttributes = IO CXSetWindowAttributes
-> (CXSetWindowAttributes -> WindowAttributes -> (IO (), Bitmask))
-> [WindowAttributes]
-> IO (CXSetWindowAttributes, Bitmask)
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 CXSetWindowAttributes
newXSetWindowAttributes CXSetWindowAttributes -> WindowAttributes -> (IO (), Bitmask)
getWindowAttribute
 where
  getWindowAttribute :: CXSetWindowAttributes -> WindowAttributes -> (IO (), Bitmask)
getWindowAttribute CXSetWindowAttributes
swa WindowAttributes
wa =
   case WindowAttributes
wa of
    CWEventMask [EventMask]
em    	 -> (SETWa(swa,event_mask,toC em),CWORD32(CWEventMask))
    CWBackingStore BackingStore
bs 	 -> (SETWa(swa,backing_store,toC bs),CWORD32(CWBackingStore))
    CWSaveUnder Bool
b     	 -> (SETWa(swa,save_under,toC b),CWORD32(CWSaveUnder))
    CWDontPropagate [EventMask]
em   -> (SETWa(swa,do_not_propagate_mask,toC em),CWORD32(CWDontPropagate))
    CWOverrideRedirect Bool
b -> (SETWa(swa,override_redirect,toC b),CWORD32(CWOverrideRedirect))
    CWBackPixel Pixel
p	 -> (SETWa(swa,background_pixel,toC p),CWORD32(CWBackPixel))
    CWCursor CursorId
c		 -> (SETWaXID(swa,cursor,toXID c),CWORD32(CWCursor))
    CWBitGravity Gravity
g 	 -> (SETWa(swa,bit_gravity,toC g),CWORD32(CWBitGravity))
    CWWinGravity Gravity
g 	 -> (SETWa(swa,win_gravity,toC g),CWORD32(CWWinGravity))
    CWBackPixmap PixmapId
p       -> (SETWaXID(swa,background_pixmap,toXID p),CWORD32(CWBackPixmap))
    CWBorderPixmap PixmapId
p     -> (SETWaXID(swa,border_pixmap,toXID p),CWORD32(CWBorderPixmap))
    CWBorderPixel Pixel
p      -> (SETWa(swa,border_pixel,toC p),CWORD32(CWBorderPixel) :: Bitmask)
    -- _ -> (return (),0) -- to skip unimplemented fields

getWindowChanges :: [WindowChanges] -> IO (CXWindowChanges, Bitmask)
getWindowChanges = IO CXWindowChanges
-> (CXWindowChanges -> WindowChanges -> (IO (), Bitmask))
-> [WindowChanges]
-> IO (CXWindowChanges, Bitmask)
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 CXWindowChanges
newXWindowChanges CXWindowChanges -> WindowChanges -> (IO (), Bitmask)
getWindowChange where
  getWindowChange :: CXWindowChanges -> WindowChanges -> (IO (), Bitmask)
getWindowChange CXWindowChanges
s WindowChanges
wc = case WindowChanges
wc of
     CWX Time
x 	      -> (SET(XWindowChanges,Int,s,x,x),CWORD32(CWX))
     CWY Time
y 	      -> (SET(XWindowChanges,Int,s,y,y),CWORD32(CWY))
     CWWidth Time
w        -> (SET(XWindowChanges,Int,s,width,w),CWORD32(CWWidth))
     CWHeight Time
h       -> (SET(XWindowChanges,Int,s,height,h),CWORD32(CWHeight))
     CWBorderWidth Time
w  -> (SET(XWindowChanges,Int,s,border_width,w),CWORD32(CWBorderWidth))
     CWStackMode StackMode
sm   -> (SET(XWindowChanges,Int,s,stack_mode,toC sm),CWORD32(CWStackMode) :: Bitmask) 

{- deriving toEnum & fromEnum appears broken (not anymore /TH 2000-11-28) -}

instance ToC CoordMode where toC :: CoordMode -> Time
toC = CoordMode -> CoordMode -> Time
forall a p. Enum a => p -> a -> Time
getEnum CoordMode
CoordModeOrigin
instance ToC Shape where toC :: Shape -> Time
toC = Shape -> Shape -> Time
forall a p. Enum a => p -> a -> Time
getEnum Shape
Complex
instance ToC BackingStore where toC :: BackingStore -> Time
toC = BackingStore -> BackingStore -> Time
forall a p. Enum a => p -> a -> Time
getEnum BackingStore
NotUseful
instance ToC Gravity where toC :: Gravity -> Time
toC = Gravity -> Gravity -> Time
forall a p. Enum a => p -> a -> Time
getEnum Gravity
ForgetGravity
instance ToC StackMode where toC :: StackMode -> Time
toC = StackMode -> StackMode -> Time
forall a p. Enum a => p -> a -> Time
getEnum StackMode
StackAbove
instance ToC ShapeKind where toC :: ShapeKind -> Time
toC = ShapeKind -> ShapeKind -> Time
forall a p. Enum a => p -> a -> Time
getEnum ShapeKind
ShapeBounding
instance ToC ShapeOperation where toC :: ShapeOperation -> Time
toC = ShapeOperation -> ShapeOperation -> Time
forall a p. Enum a => p -> a -> Time
getEnum ShapeOperation
ShapeSet
instance ToC Ordering' where toC :: Ordering' -> Time
toC = Ordering' -> Ordering' -> Time
forall a p. Enum a => p -> a -> Time
getEnum Ordering'
Unsorted

instance ToC Button where toC :: Button -> Time
toC Button
AnyButton  = CCONST(AnyButton)
			  toC (Button Time
i) = Time
i

getEvent :: Window -> XEvent -> IO CXEvent
getEvent Window
w XEvent
e = do
    CXEvent
xe <- IO CXEvent
newXEvent
    SET(XAnyEvent,Window,xe,window,w::Window)
    case XEvent
e of
      SelectionNotify Time
time (Selection Atom
sel Atom
target Atom
props) -> do
        SET(XSelectionEvent,Int,xe,type,CCONST(SelectionNotify)::Int)
        SET(XSelectionEvent,Atom,xe,selection, sel)
        SET(XSelectionEvent,Atom,xe,target, target)
        SET(XSelectionEvent,Atom,xe,property, props)
        SET(XSelectionEvent,Time,xe,time,time)
    CXEvent -> IO CXEvent
forall (m :: * -> *) a. Monad m => a -> m a
return CXEvent
xe


storePoints :: [Point] -> IO (CXPoint, Time)
storePoints [Point]
ps = (Time -> IO CXPoint)
-> (CXPoint -> (Time, Point) -> IO ())
-> [Point]
-> IO (CXPoint, Time)
forall (m :: * -> *) a1 a2 b.
Monad m =>
(Time -> m a1) -> (a1 -> (Time, a2) -> m b) -> [a2] -> m (a1, Time)
getArray Time -> IO CXPoint
newXPointArray
	          (\CXPoint
xpoints (Time
i,Point Time
x Time
y) -> do SETI(XPoint,Int,xpoints,i,x,x)
					        SETI(XPoint,Int,xpoints,i,y,y)) ps

storeRectangles :: [Rect] -> IO (CXRectangle, Time)
storeRectangles [Rect]
rs =
  (Time -> IO CXRectangle)
-> (CXRectangle -> (Time, Rect) -> IO ())
-> [Rect]
-> IO (CXRectangle, Time)
forall (m :: * -> *) a1 a2 b.
Monad m =>
(Time -> m a1) -> (a1 -> (Time, a2) -> m b) -> [a2] -> m (a1, Time)
getArray Time -> IO CXRectangle
newXRectangleArray
           (\CXRectangle
rsa (Time
i,Rect (Point Time
x Time
y) (Point Time
w Time
h)) -> do
		     SETI(XRectangle,Int,rsa,i,x,x)
		     SETI(XRectangle,Int,rsa,i,y,y)
		     SETI(XRectangle,Int,rsa,i,width,w)
		     SETI(XRectangle,Int,rsa,i,height,h)) rs