{-# 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 -> Int -> IO ()
xUngrabPointer Display
d Int
currentTime
   XCommand
Flush -> Display -> IO ()
xFlush Display
d
   ClearArea (Rect (Point Int
x Int
y) (Point Int
wi Int
he)) Bool
exposures ->
      Display -> Window -> Int -> Int -> Int -> Int -> Bool -> IO ()
xClearArea Display
d Window
w Int
x Int
y Int
wi Int
he Bool
exposures
   GrabButton Bool
oe Button
button ModState
ms [EventMask]
evm ->
      Display
-> Int
-> Int
-> Window
-> Bool
-> Int
-> Int
-> Int
-> Window
-> CursorId
-> IO ()
xGrabButton Display
d (forall a. ToC a => a -> Int
toC Button
button) Int
anyModifier Window
w Bool
oe (forall a. ToC a => a -> Int
toC [EventMask]
evm) Int
grabModeAsync Int
grabModeAsync Window
windowNone  CursorId
cursorNone
   UngrabButton Button
b ModState
ms ->
     --_casm_ ``XUngrabButton(%0,%1,AnyModifier,%2);'' d (toC b) w
     Display -> Int -> Int -> Window -> IO ()
xUngrabButton Display
d (forall a. ToC a => a -> Int
toC Button
b) Int
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 -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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) = 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 Int
x Int
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
      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
      forall {a}. HasAddr a => a -> IO ()
freePtr CXWMHints
h
   ShapeCombineMask ShapeKind
kind (Point Int
x Int
y) PixmapId
p ShapeOperation
op ->
     Display
-> Window
-> ShapeKind
-> Int
-> Int
-> PixmapId
-> ShapeOperation
-> IO ()
xShapeCombineMask Display
d Window
w ShapeKind
kind Int
x Int
y PixmapId
p ShapeOperation
op
   ShapeCombineRectangles ShapeKind
kind (Point Int
x Int
y) [Rect]
rs ShapeOperation
op Ordering'
ord -> do
      (CXRectangle
rsa,Int
size) <- [Rect] -> IO (CXRectangle, Int)
storeRectangles [Rect]
rs
      Display
-> Window
-> ShapeKind
-> Int
-> Int
-> CXRectangle
-> Int
-> ShapeOperation
-> Ordering'
-> IO ()
xShapeCombineRectangles Display
d Window
w ShapeKind
kind Int
x Int
y CXRectangle
rsa Int
size ShapeOperation
op Ordering'
ord
      forall {a}. HasAddr a => a -> IO ()
freePtr CXRectangle
rsa
   ShapeCombineShape ShapeKind
dst (Point Int
x Int
y)  PixmapId
p ShapeKind
src ShapeOperation
op ->
       Display
-> Window
-> ShapeKind
-> Int
-> Int
-> PixmapId
-> ShapeKind
-> ShapeOperation
-> IO ()
xShapeCombineShape Display
d Window
w ShapeKind
dst Int
x Int
y PixmapId
p ShapeKind
src ShapeOperation
op
   --RmDestroyDatabase RmDatabase |
   --RmCombineDatabase RmDatabase RmDatabase Bool |
   --RmPutLineResource RmDatabase String |
   SetWMProtocols [Atom]
atoms -> Display -> Window -> [Atom] -> Int -> IO ()
xSetWMProtocols Display
d Window
w [Atom]
atoms (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Atom]
atoms)
   SendEvent Window
dst Bool
propagate [EventMask]
evm XEvent
e -> do
     CXEvent
xe <- Window -> XEvent -> IO CXEvent
getEvent Window
dst XEvent
e
     Int
status <- Display -> Window -> Bool -> Bitmask -> CXEvent -> IO Int
xSendEvent Display
d Window
dst Bool
propagate (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. ToC a => a -> Int
toC [EventMask]
evm) CXEvent
xe
     forall (m :: * -> *) a. Monad m => a -> m a
return ()
   SetSelectionOwner Bool
getit Atom
sel ->
     Display -> Atom -> Window -> Int -> IO ()
xSetSelectionOwner Display
d Atom
sel (if Bool
getit then Window
w else Window
windowNone)  Int
currentTime
   ConvertSelection  (Selection Atom
s Atom
t Atom
p) ->
     Display -> Atom -> Atom -> Atom -> Window -> Int -> IO ()
xConvertSelection Display
d Atom
s Atom
t Atom
p Window
w Int
currentTime
   ChangeProperty Window
w Atom
p Atom
t form :: Int
form@Int
8 PropertyMode
mode String
s -> -- !!
     Display
-> Window
-> Atom
-> Atom
-> Int
-> PropertyMode
-> String
-> Int
-> IO ()
xChangeProperty Display
d Window
w Atom
p Atom
t Int
form PropertyMode
mode String
s (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
   FreeColors ColormapId
cm [Pixel]
pixls Pixel
planes ->
     do ColormapId
cmid <- Display -> ColormapId -> IO ColormapId
dcmap Display
d ColormapId
cm
	(CPixelArray
pxarr,Int
size) <- forall {a} {h}. (IsPtr a, CVar a h) => [h] -> IO (a, Int)
toArray [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p|Pixel Word
p<-[Pixel]
pixls] -- hmm
	Display -> ColormapId -> CPixelArray -> Int -> Pixel -> IO ()
xFreeColors Display
d ColormapId
cmid CPixelArray
pxarr Int
size Pixel
planes
   ReparentWindow Window
newParent0 ->
     do Window
newParent <- if Window
newParent0forall a. Eq a => a -> a -> Bool
==Window
rootWindow
                     then Display -> IO Window
xDefaultRootWindow Display
d
                     else 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 Int
x Int
y) -> Display -> Window -> Window -> Int -> Int -> IO ()
xReparentWindow Display
d Window
w Window
newParent Int
x Int
y
   --WarpPointer Point |
   SetRegion GCId
gc Rect
r -> -- !!! modifies a GC -- cache problems!
     do (CXRectangle
rsa,Int
_) <- [Rect] -> IO (CXRectangle, Int)
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
	forall {a}. HasAddr a => a -> IO ()
freePtr CXRectangle
rsa
   --AddToSaveSet |
   --RemoveFromSaveSet 
   Bell Int
n -> Display -> Int -> IO ()
xBell Display
d Int
n

   XCommand
_ -> Handle -> String -> IO ()
hPutStr Handle
stderr (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 Int
x1 Int
y1) (Point Int
x2 Int
y2)) -> 
	    Display -> DrawableId -> GCId -> Int -> Int -> Int -> Int -> IO ()
xDrawLine Display
d DrawableId
drw GCId
gc Int
x1 Int
y1 Int
x2 Int
y2
	  DrawImageString (Point Int
x Int
y) String
s ->
	    Display
-> DrawableId -> GCId -> Int -> Int -> String -> Int -> IO ()
xDrawImageString Display
d DrawableId
drw GCId
gc Int
x Int
y String
s (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
	  DrawString (Point Int
x Int
y) String
s ->
	    Display
-> DrawableId -> GCId -> Int -> Int -> String -> Int -> IO ()
xDrawString Display
d DrawableId
drw GCId
gc Int
x Int
y String
s (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
	  DrawImageString16 (Point Int
x Int
y) String
s ->
	    do let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
	       CString
cs <- forall {a}. Enum a => [a] -> Int -> IO CString
marshallString16' String
s Int
n
	       Display
-> DrawableId -> GCId -> Int -> Int -> CString -> Int -> IO ()
xDrawImageString16 Display
d DrawableId
drw GCId
gc Int
x Int
y CString
cs Int
n
	  DrawString16 (Point Int
x Int
y) String
s ->
	    do let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
	       CString
cs <- forall {a}. Enum a => [a] -> Int -> IO CString
marshallString16' String
s Int
n
	       Display
-> DrawableId -> GCId -> Int -> Int -> CString -> Int -> IO ()
xDrawString16 Display
d DrawableId
drw GCId
gc Int
x Int
y CString
cs Int
n
	  DrawRectangle (Rect (Point Int
x1 Int
y1) (Point Int
x2 Int
y2)) ->
            Display -> DrawableId -> GCId -> Int -> Int -> Int -> Int -> IO ()
xDrawRectangle Display
d DrawableId
drw GCId
gc Int
x1 Int
y1 Int
x2 Int
y2
	  FillRectangle (Rect (Point Int
x1 Int
y1) (Point Int
x2 Int
y2)) ->
            Display -> DrawableId -> GCId -> Int -> Int -> Int -> Int -> IO ()
xFillRectangle Display
d DrawableId
drw GCId
gc Int
x1 Int
y1 Int
x2 Int
y2
	  FillPolygon Shape
shape CoordMode
coordmode [Point]
ps -> do
	      (CXPoint
xpoints,Int
size) <- [Point] -> IO (CXPoint, Int)
storePoints [Point]
ps
	      Display
-> DrawableId
-> GCId
-> CXPoint
-> Int
-> Shape
-> CoordMode
-> IO ()
xFillPolygon Display
d DrawableId
drw GCId
gc CXPoint
xpoints Int
size Shape
shape CoordMode
coordmode
	      forall {a}. HasAddr a => a -> IO ()
freePtr CXPoint
xpoints
	  DrawLines CoordMode
coordmode [Point]
ps -> do
	      (CXPoint
xpoints,Int
size) <- [Point] -> IO (CXPoint, Int)
storePoints [Point]
ps
	      Display
-> DrawableId -> GCId -> CXPoint -> Int -> CoordMode -> IO ()
xDrawLines Display
d DrawableId
drw GCId
gc CXPoint
xpoints Int
size CoordMode
coordmode
	      forall {a}. HasAddr a => a -> IO ()
freePtr CXPoint
xpoints
	  DrawArc (Rect (Point Int
x Int
y) (Point Int
wi Int
he)) Int
a1 Int
a2 ->
	      Display
-> DrawableId
-> GCId
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> IO ()
xDrawArc Display
d DrawableId
drw GCId
gc (Int -> Unsigned32
f Int
x) (Int -> Unsigned32
f Int
y) (Int -> Unsigned32
f Int
wi) (Int -> Unsigned32
f Int
he) (Int -> Unsigned32
f Int
a1) (Int -> Unsigned32
f Int
a2)
            where f :: Int -> Unsigned32
f = forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  FillArc (Rect (Point Int
x Int
y) (Point Int
wi Int
he)) Int
a1 Int
a2 ->
	      Display
-> DrawableId
-> GCId
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> IO ()
xFillArc Display
d DrawableId
drw GCId
gc (Int -> Unsigned32
f Int
x) (Int -> Unsigned32
f Int
y) (Int -> Unsigned32
f Int
wi) (Int -> Unsigned32
f Int
he) (Int -> Unsigned32
f Int
a1) (Int -> Unsigned32
f Int
a2)
            where f :: Int -> Unsigned32
f = forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  CopyArea Drawable
src (Rect (Point Int
srcx Int
srcy) (Point Int
wi Int
he))
		       (Point Int
dstx Int
dsty) ->
	    Display
-> DrawableId
-> DrawableId
-> GCId
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> IO ()
xCopyArea Display
d (Drawable -> DrawableId
getdr Drawable
src) DrawableId
drw GCId
gc (Int -> Unsigned32
i32 Int
srcx) (Int -> Unsigned32
i32 Int
srcy) (Int -> Unsigned32
u32 Int
wi) (Int -> Unsigned32
u32 Int
he) (Int -> Unsigned32
i32 Int
dstx) (Int -> Unsigned32
i32 Int
dsty)
	  CopyPlane Drawable
src (Rect (Point Int
srcx Int
srcy) (Point Int
wi Int
he)) 
			(Point Int
dstx Int
dsty) Int
plane ->
            --print (gc,drw,cmd) >>
	    Display
-> DrawableId
-> DrawableId
-> GCId
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Word
-> IO ()
xCopyPlane Display
d (Drawable -> DrawableId
getdr Drawable
src)
		       DrawableId
drw GCId
gc (Int -> Unsigned32
f Int
srcx) (Int -> Unsigned32
f Int
srcy) (Int -> Unsigned32
f Int
wi) (Int -> Unsigned32
f Int
he)
                       (Int -> Unsigned32
f Int
dstx) (Int -> Unsigned32
f Int
dsty) (forall a. Bits a => a -> Int -> a
shiftL Word
1 Int
plane)
            -- >>putStrLn "done"
            where f :: Int -> Unsigned32
f = forall a b. (Integral a, Num b) => a -> b
fromIntegral
	  DrawPoint (Point Int
x Int
y) -> Display -> DrawableId -> GCId -> Int -> Int -> IO ()
xDrawPoint Display
d DrawableId
drw GCId
gc Int
x Int
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 x y) s ->
--	    xDrawImageString d drw gc x y (unpackPS s) (lengthPS s) -- !!
--	  DrawStringPS (Point x y) s ->
--	    xDrawString d drw gc x y (unpackPS s) (lengthPS s) -- !!
          DrawCommand
_ -> Handle -> String -> IO ()
hPutStr Handle
stderr (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 Int
x Int
y) (Point Int
w Int
h)) (ImageFormat Int
format) [Pixel]
pixels =
        do --hPutStrLn stderr $ "Entering createPutImage "++show rect
	   Int
screen <- Display -> IO Int
xDefaultScreen Display
d
	   Int
depth <- Display -> Int -> IO Int
xDefaultDepth Display
d Int
screen
	   Int
bpp <- Display -> Int -> IO Int
default_bpp Display
d Int
depth
	   --hPutStrLn stderr ("bpp="++show bpp)
	   let byte_depth :: Int
byte_depth = (Int
depthforall a. Num a => a -> a -> a
+Int
7) forall a. Integral a => a -> a -> a
`div` Int
8
	       bytes_pp :: Int
bytes_pp = (Int
bppforall a. Num a => a -> a -> a
+Int
7) forall a. Integral a => a -> a -> a
`div` Int
8
	       bitmap_pad :: Int
bitmap_pad = Int
32
	       bytes_per_line :: Int
bytes_per_line = ((Int
wforall a. Num a => a -> a -> a
*Int
bytes_ppforall a. Num a => a -> a -> a
+Int
3) forall a. Integral a => a -> a -> a
`div` Int
4) forall a. Num a => a -> a -> a
* Int
4 -- assumes bitmap_pad == 32
	       nullCount :: Int
nullCount = Int
bytes_per_line forall a. Num a => a -> a -> a
- Int
wforall a. Num a => a -> a -> a
*Int
bytes_pp
	       size :: Int
size= Int
wforall a. Num a => a -> a -> a
*Int
h
	       pxlines :: [[Pixel]]
pxlines = forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chopList (forall a. Int -> [a] -> ([a], [a])
splitAt Int
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
byteOrderforall 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 forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse (forall {t} {a}. (Eq t, Num t, Enum a) => t -> Int -> [a]
lsb' Int
byte_depth (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p))
	       pad :: String
pad = forall a. Int -> a -> [a]
replicate (Int
bytes_ppforall a. Num a => a -> a -> a
-Int
byte_depth) Char
'\0'
	       lsb :: Pixel -> String
lsb (Pixel Word
p) = forall {t} {a}. (Eq t, Num t, Enum a) => t -> Int -> [a]
lsb' Int
byte_depth (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p) forall a. [a] -> [a] -> [a]
++ String
pad
	       lsb' :: t -> Int -> [a]
lsb' t
0 Int
_ = []
	       lsb' t
n Int
p = forall a. Enum a => Int -> a
toEnum (Int
p forall a. Integral a => a -> a -> a
`mod` Int
256) forall a. a -> [a] -> [a]
: t -> Int -> [a]
lsb' (t
nforall a. Num a => a -> a -> a
-t
1) (Int
p forall a. Integral a => a -> a -> a
`div` Int
256)
	       linePad :: String
linePad = forall a. Int -> a -> [a]
replicate Int
nullCount Char
'\0'
	       byteLine :: t Pixel -> String
byteLine t Pixel
pxls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pixel -> String
pxlToBytes t Pixel
pxls forall a. [a] -> [a] -> [a]
++ String
linePad
	       bytes :: String
bytes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 -> Int -> IO CVisual
xDefaultVisual Display
d Int
screen
           --hPutStrLn stderr "Checkpoint 2 in createPutImage"
           --if bytes==bytes then return () else undefined
           --hPutStrLn stderr "Checkpoint 3 in createPutImage"
	   CString
cbytes <- String -> Int -> IO CString
marshallString' String
bytes (Int
hforall a. Num a => a -> a -> a
*Int
bytes_per_line)
	   CXImage
image <- Display
-> CVisual
-> Int
-> Int
-> Int
-> CString
-> Int
-> Int
-> Int
-> Int
-> IO CXImage
xCreateImage Display
d CVisual
dv Int
depth Int
format Int
0 CString
cbytes Int
w Int
h Int
bitmap_pad Int
bytes_per_line
           --hPutStrLn stderr $ "Checkpoint 4 in createPutImage "++show image
	   Display
-> DrawableId
-> GCId
-> CXImage
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> Unsigned32
-> IO ()
xPutImage Display
d DrawableId
drw GCId
gc CXImage
image Unsigned32
0 Unsigned32
0 (Int -> Unsigned32
i32 Int
x) (Int -> Unsigned32
i32 Int
y) (Int -> Unsigned32
i32 Int
w) (Int -> Unsigned32
i32 Int
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"
	   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 :: Int -> Unsigned32
i32 = forall a. Enum a => Int -> a
toEnum
u32 :: Int->Unsigned32
u32 :: Int -> Unsigned32
u32 = forall a. Enum a => Int -> a
toEnum

getWindowAttributes :: [WindowAttributes] -> IO (CXSetWindowAttributes, Bitmask)
getWindowAttributes = 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 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 = 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 IO CXWindowChanges
newXWindowChanges CXWindowChanges -> WindowChanges -> (IO (), Bitmask)
getWindowChange where
  getWindowChange :: CXWindowChanges -> WindowChanges -> (IO (), Bitmask)
getWindowChange CXWindowChanges
s WindowChanges
wc = case WindowChanges
wc of
     CWX Int
x 	      -> (SET(XWindowChanges,Int,s,x,x),CWORD32(CWX))
     CWY Int
y 	      -> (SET(XWindowChanges,Int,s,y,y),CWORD32(CWY))
     CWWidth Int
w        -> (SET(XWindowChanges,Int,s,width,w),CWORD32(CWWidth))
     CWHeight Int
h       -> (SET(XWindowChanges,Int,s,height,h),CWORD32(CWHeight))
     CWBorderWidth Int
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 -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum CoordMode
CoordModeOrigin
instance ToC Shape where toC :: Shape -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum Shape
Complex
instance ToC BackingStore where toC :: BackingStore -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum BackingStore
NotUseful
instance ToC Gravity where toC :: Gravity -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum Gravity
ForgetGravity
instance ToC StackMode where toC :: StackMode -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum StackMode
StackAbove
instance ToC ShapeKind where toC :: ShapeKind -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum ShapeKind
ShapeBounding
instance ToC ShapeOperation where toC :: ShapeOperation -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum ShapeOperation
ShapeSet
instance ToC Ordering' where toC :: Ordering' -> Int
toC = forall {a} {p}. Enum a => p -> a -> Int
getEnum Ordering'
Unsorted

instance ToC Button where toC :: Button -> Int
toC Button
AnyButton  = CCONST(AnyButton)
			  toC (Button Int
i) = Int
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 Int
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)
    forall (m :: * -> *) a. Monad m => a -> m a
return CXEvent
xe


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

storeRectangles :: [Rect] -> IO (CXRectangle, Int)
storeRectangles [Rect]
rs =
  forall {m :: * -> *} {a1} {a2} {b}.
Monad m =>
(Int -> m a1) -> (a1 -> (Int, a2) -> m b) -> [a2] -> m (a1, Int)
getArray Int -> IO CXRectangle
newXRectangleArray
           (\CXRectangle
rsa (Int
i,Rect (Point Int
x Int
y) (Point Int
w Int
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