{-# LANGUAGE CPP #-}
module DoXCommand(doXCommand) where
import Command
import Event
import Geometry
import Xtypes
import DrawTypes
import HbcUtils(chopList)
import DoXRequest(getGCValues,translateCoordinates)
import XCallTypes
import StructFuns
import Xlib
import Marshall
import MyForeign
import CString16
import System.IO(hPutStr,hPutStrLn,stderr)
import PackedString(lengthPS,unpackPS)
import Data.Bits
default (Int)
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 ->
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
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
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]
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
SetRegion GCId
gc Rect
r ->
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
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 ->
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)
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
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
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
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
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
#else
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
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
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
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
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)
CXImage -> Addr -> IO ()
setXImage_data CXImage
image Addr
nullAddr
CXImage -> IO ()
xDestroyImage CXImage
image
CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cbytes
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)
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)
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