{-# LANGUAGE CPP #-}
{- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/shape.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}
module Xlib where
import Marshall
import MyForeign
import CSizes
import Xtypes
import Visual
import Font(FontDirection)
import CString16(CString16)

import DrawTypes

import Control.Monad(zipWithM_)
--import Ap
import Data.Word(Word,Word32)
--import CCall
default(Int)

#include "structs.h"

type Unsigned = Int -- hmm
type Unsigned32 = Int32 -- hmm
type Status = Int
type Screen = Int
type Bitmask = Word32
type XlibKeySym = XID -- KeySym in Xlib, defined as String in Fudgets
type ClipOrdering = Ordering'
type CPixelArray = CLong
type CStringArray = CString
type CXFontStructArray = CXFontStruct
type CDisplay = Addr
type CGCId = Addr
newtype Region = Region Addr

#define FI(f) foreign import ccall unsafe "f" prim/**/f
#define PXlib(f,p,h) FI(X/**/f) :: p ; x/**/f :: h ; x/**/f = call primX/**/f
#define Xlib(f,h) PXlib(f,h,h)

#define PReq0(f,pr,r) PXlib(f,CDisplay -> IO pr, Display -> IO r)
#define Req0(f,r) PReq0(f,r,r)
#define Req(f,t,r) PReq(f,t,r,t,r)
#define PReq(f,p,pr,t,r) PXlib(f,CDisplay -> p -> IO pr, Display-> t ->IO r)
#define WindowReq(f,t,r) Req(f,Window->t,r)
#define PWindowReq(f,pt,pr,t,r) PReq(f,Window->pt,pr,Window->t,r)
#define WindowReqP(f,t,pr,r) PReq(f,Window->t,pr,Window->t,r)
#define DrawReq(f,t,r) Req(f,DrawableId->t,r)
#define DrawReqP(f,t,pr,r) PReq(f,DrawableId->t,pr,DrawableId->t,r)

#define Cmd0(f) PXlib(f,CDisplay -> IO (), Display-> IO ())
#define Cmd(f,t) Req(f,t,())
#define PCmd(f,p,t) PXlib(f,CDisplay -> p -> IO (), Display-> t ->IO ())
#define WindowCmd0(f) Cmd(f,Window)
#define WindowCmd(f,t) Cmd(f,Window->t)
#define PWindowCmd(f,p,t) PCmd(f,Window->p,Window->t)
#define DrawCmd(f,t) PCmd(f,DrawableId->CGCId->t,DrawableId->GCId->t)
#define DrawPCmd(f,p,t) PCmd(f,DrawableId->CGCId->p,DrawableId->GCId->t)

--- Calls ---------------------------------------------------------------------
PXlib(OpenDisplay,  CString -> IO CDisplay, String -> IO Display)
Cmd0(CloseDisplay)
Req0(ConnectionNumber,Int32)
Cmd0(Flush)
Cmd(NextEvent,CXEvent)
WindowReq(CheckWindowEvent,Int->CXEvent,Bool)
Req0(Pending,Int)
Cmd(FreePixmap,PixmapId)
Cmd(Synchronize,Bool) -- result is ignored.
Cmd(Sync,Bool)
Cmd(Bell,Int)

FI(XInitThreads) :: IO Int
xInitThreads :: IO Bool
xInitThreads = (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) IO Int
primXInitThreads
Cmd0(LockDisplay)
Cmd0(UnlockDisplay)

FI(XFree) :: Addr -> IO ()
xFree :: a -> IO ()
xFree a
p = CDisplay -> IO ()
primXFree (a -> CDisplay
forall a. HasAddr a => a -> CDisplay
addrOf a
p)

Req0(DefaultScreen,Screen)
Req0(DefaultRootWindow,Window)
PReq0(ImageByteOrder,Int,ByteOrder)
Req(DefaultDepth,Screen,Int)
Req(BlackPixel,Int,Unsigned)
Req(WhitePixel,Int,Unsigned)
Req(DefaultColormap,Int,ColormapId)
Req(DefaultVisual,Screen,CVisual)

PReq(LoadFont,CString,FontId,String,FontId)
Req(QueryFont,FontId,CXFontStruct)
PReq(LoadQueryFont,CString,CXFontStruct,String,CXFontStruct)
PReq(ListFonts,CString->Int->CLong,CStringArray,String->Int->CLong,CStringArray)
Xlib(FreeFontNames,CStringArray->IO())
PReq(ListFontsWithInfo,CString->Int->CInt32->CCXFontStruct,CStringArray,String->Int->CInt32->CCXFontStruct,CStringArray)
Xlib(FreeFontInfo,CStringArray->CXFontStructArray->Int32->IO ())
Cmd(QueryTextExtents16,FontId->CString16->Int->CLong->CLong->CLong->CXCharStruct)

Req(CreateFontCursor,Int,CursorId)
Req(CreatePixmap,DrawableId->Unsigned->Unsigned->Unsigned,PixmapId)
PReq(InternAtom,CString->Bool,Atom,String->Bool,Atom)
Req(GetAtomName,Atom,CString)
Req(AllocColor,ColormapId->CXColor,Status)
PReq(AllocNamedColor,ColormapId->CString->CXColor->CXColor,Status,ColormapId->String->CXColor->CXColor,Status)
Cmd(QueryColor,ColormapId->CXColor)
Cmd(FreeColors,ColormapId->CPixelArray->Int->Pixel)
{- -- This creates a dangling reference to the image data!
PReq(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage,
                 CVisual->Int->Int->Int->String->Int->Int->Int->Int,CXImage)
-}
Req(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage)

DrawCmd(PutImage,CXImage->Int32->Int32->Int32->Int32->Int32->Int32)

-- Xlib(DestroyImage,CXImage->IO ()) -- XDestroyImage is a macro in X11/Xutil.h
foreign import ccall "asyncinput.h" xDestroyImage :: CXImage -> IO ()


WindowCmd0(DestroyWindow)
WindowCmd0(MapRaised)
WindowCmd0(LowerWindow)
WindowCmd0(UnmapWindow)
WindowCmd0(ClearWindow)
WindowCmd(ClearArea,Int->Int->Int->Int->Bool)
WindowReq(CreateSimpleWindow,Int->Int->Unsigned->Unsigned->Unsigned->Unsigned->Unsigned,Window)
PWindowCmd(StoreName,CString,String)
WindowCmd(SetClassHint,CXClassHint)
WindowCmd(ConfigureWindow,Bitmask->CXWindowChanges)
WindowCmd(ChangeWindowAttributes,Bitmask->CXSetWindowAttributes)
WindowCmd(ReparentWindow,Window->Int->Int)
PWindowCmd(SetWMProtocols,CAtomArray->Int,[Atom]->Int)
WindowCmd(SetNormalHints,CXSizeHints)
WindowCmd(SetWMHints,CXWMHints)
WindowReq(SendEvent,Bool->Bitmask->CXEvent,Status)
PWindowCmd(ChangeProperty,Atom->Atom->Int->PropertyMode->CString->Int,Atom->Atom->Int->PropertyMode->String->Int)
WindowReq(GetWindowProperty,Atom->Int->Int->Bool->Atom->CAtom->CLong->CLong->CLong->CCString,Int)
WindowReq(QueryPointer,CLong->CLong->CLong->CLong->CLong->CLong->CLong,Bool)
WindowReq(TranslateCoordinates,Window->Int->Int->CInt32->CInt32->CLong,Bool)
PWindowCmd(ShapeCombineMask,Int->Int->Int->PixmapId->Int,ShapeKind->Int->Int->PixmapId->ShapeOperation)
PWindowCmd(ShapeCombineRectangles,Int->Int->Int->CXRectangleArray->Int->Int->Int,ShapeKind->Int->Int->CXRectangleArray->Int->ShapeOperation->ClipOrdering)
PWindowCmd(ShapeCombineShape,Int->Int->Int->PixmapId->Int->Int,ShapeKind->Int->Int->PixmapId->ShapeKind->ShapeOperation)

Cmd(GrabButton,Int->Int->Window->Bool->Unsigned->Int->Int->Window->CursorId)
Cmd(UngrabButton,Int->Int->Window)
WindowReqP(GrabPointer,Bool->Unsigned->Int->Int->Window->CursorId->Time,Int,GrabPointerResult)
Cmd(UngrabPointer,Time)
Cmd(SetSelectionOwner,Atom->Window->Time)
Cmd(ConvertSelection,Atom->Atom->Atom->Window->Time)

DrawCmd(DrawPoint,Int->Int)
DrawCmd(DrawLine,Int->Int->Int->Int)
DrawPCmd(DrawLines,CXPointArray->Int->Int,CXPointArray->Int->CoordMode)
DrawPCmd(DrawImageString,Int->Int->CString->Int,Int->Int->String->Int)
DrawPCmd(DrawString,Int->Int->CString->Int,Int->Int->String->Int)
DrawPCmd(DrawImageString16,Int->Int->CString16->Int,Int->Int->CString16->Int)
DrawPCmd(DrawString16,Int->Int->CString16->Int,Int->Int->CString16->Int)
DrawCmd(DrawRectangle,Int->Int->Int->Int)
DrawCmd(FillRectangle,Int->Int->Int->Int)
DrawCmd(DrawArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
DrawCmd(FillArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
DrawPCmd(FillPolygon,CXPointArray->Int->Int->Int,CXPointArray->Int->Shape->CoordMode)
PCmd(CopyArea,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
PCmd(CopyPlane,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word)

#define GCCmd(f,t) PCmd(f,CGCId->t,GCId->t)

DrawReqP(CreateGC,Bitmask->CXGCValues,CGCId,GCId)
PCmd(CopyGC,CGCId->Bitmask->CGCId,GCId->Bitmask->GCId)
GCCmd(ChangeGC,Bitmask->CXGCValues)
PCmd(FreeGC,CGCId,GCId)

GCCmd(SetForeground,Unsigned)
GCCmd(SetBackground,Unsigned)
GCCmd(SetPlaneMask,Bitmask)
PCmd(SetFunction,CGCId->Int,GCId->GCFunction)
PCmd(SetState,CGCId->Unsigned->Unsigned->Int->Unsigned,GCId->Unsigned->Unsigned->GCFunction->Unsigned)

PXlib(KeysymToString,XlibKeySym->IO CString,XlibKeySym->IO (Maybe String))

Req(ReadBitmapFile,DrawableId->CString->CInt32->CInt32->CXID->CInt32->CInt32,Int)
Req(CreateBitmapFromData,DrawableId->CString->Int32->Int32,PixmapId)

--- Regions -------------------------------------------------------------------
Xlib(CreateRegion,IO Region)
PCmd(SetRegion,CGCId->Region,GCId->Region)
Xlib(DestroyRegion,Region->IO ())
Xlib(UnionRectWithRegion,CXRectangle->Region->Region->IO ())
IDAR(Region)

--- Double buffer extension ---------------------------------------------------
Req(dbeQueryExtension,CLong->CLong,Int)
PWindowReq(dbeAllocateBackBufferName,Int,DbeBackBufferId,SwapAction,DbeBackBufferId)
Req(dbeSwapBuffers,CXdbeSwapInfoArray->Int,Status)

H_ARRAY(XdbeSwapInfo)
ENUMAR(SwapAction)
IDAR(DbeBackBufferId)
--- Types ---------------------------------------------------------------------

IORC(CDisplay,Display,fmap (Display . a2i))
instance PrimArg Display CDisplay c where marshall :: (CDisplay -> c) -> Display -> c
marshall CDisplay -> c
c (Display Int
d) = CDisplay -> c
c (Int -> CDisplay
i2a Int
d)

IORC(CGCId,GCId,fmap (GCId . a2i))

instance PrimArg GCId CGCId c where marshall :: (CDisplay -> c) -> GCId -> c
marshall CDisplay -> c
c (GCId Int
d) = CDisplay -> c
c (Int -> CDisplay
i2a Int
d)


-- Instances for resource identifiers and simple values
IDAR(Atom)
IDAR(ColormapId)
IDAR(CursorId)
IDAR(DrawableId)
IDAR(FontId)
IDAR(Pixel)
IDAR(PixmapId)
IDAR(PropertyMode)
IDAR(VisualID)
IDAR(Window)
IDAR0(Word32)
IDAR0(Word)
IDAR0(XID)
ENUMAR(ByteOrder)
ENUMAR(CoordMode)
ENUMAR(DisplayClass)
ENUMAR(FontDirection)
ENUMAR(GrabPointerResult)
ENUMAR(GCFunction)
ENUMAR(GCLineStyle)
ENUMAR(GCCapStyle)
ENUMAR(GCJoinStyle)
ENUMAR(GCSubwindowMode)
ENUMAR(GCFillStyle)
ENUMAR(ClipOrdering)
ENUMAR(Shape)
ENUMAR(ShapeKind)
ENUMAR(ShapeOperation)

IDAR0(CXID)
ISTORE(XID)

instance CVar CXID XID

--- Structured types ----------------------------------------------------------
H_STRUCTTYPE(XColor)
H_STRUCTTYPE(XClassHint)
H_STRUCTTYPE(XGCValues)
H_STRUCTTYPE(XSetWindowAttributes)
H_STRUCTTYPE(XSizeHints)
H_STRUCTTYPE(XWMHints)
H_STRUCTTYPE(XWindowChanges)

H_ARRAY(Atom)
ISTORE(Atom)
instance CVar CAtom Atom
instance PrimArg [Atom] CAtom (Int->IO a) where
  marshall :: (CAtomArray -> Int -> IO a) -> [Atom] -> Int -> IO a
marshall CAtomArray -> Int -> IO a
pf [Atom]
as Int
n =
    do CAtomArray
aa <- Int -> IO CAtomArray
forall a. IsPtr a => Int -> IO a
newArray Int
n
       (Int -> Int -> IO ()) -> [Int] -> [Int] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (CDisplay -> Int -> Int -> IO ()
forall a. Storable a => CDisplay -> Int -> a -> IO ()
pokeElemOff (CAtomArray -> CDisplay
forall a. HasAddr a => a -> CDisplay
addrOf CAtomArray
aa)) [Int
0..(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] [Int
a|Atom Int
a<-[Atom]
as]
       a
r<-CAtomArray -> Int -> IO a
pf CAtomArray
aa Int
n
       CAtomArray -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CAtomArray
aa
       a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

H_STRUCTTYPE(XEvent)
type CXAnyEvent = CXEvent
type CXKeyEvent = CXEvent
type CXButtonEvent = CXEvent
type CXMotionEvent = CXEvent
type CXCrossingEvent = CXEvent
type CXFocusChangeEvent = CXEvent
type CXExposeEvent = CXEvent
type CXGraphicsExposeEvent = CXEvent
type CXNoExposeEvent = CXEvent
type CXVisibilityEvent = CXEvent
type CXCreateWindowEvent = CXEvent
type CXDestroyWindowEvent = CXEvent
type CXUnmapEvent = CXEvent
type CXMapEvent = CXEvent
type CXMapRequestEvent = CXEvent
type CXReparentEvent = CXEvent
type CXConfigureEvent = CXEvent
type CXGravityEvent = CXEvent
type CXResizeRequestEvent = CXEvent
type CXConfigureRequestEvent = CXEvent
type CXCirculateEvent = CXEvent
type CXClientMessageEvent = CXEvent
type CXSelectionClearEvent = CXEvent
type CXSelectionRequestEvent = CXEvent
type CXSelectionEvent = CXEvent

H_ARRAY(XPoint)
H_ARRAY(XRectangle)
C_STRUCTTYPE(XFontStruct);IDAR0(CXFontStruct)

--C_STRUCTTYPE(XCharStruct);IDAR0(CXCharStruct)
NEWTYPE(HT(XCharStruct));IPTR(XCharStruct);ISTORE(HT(XCharStruct));
INSTCCALL(HT(XCharStruct));IDAR0(CXCharStruct)

C_STRUCTTYPE(Visual);IDAR0(CVisual)
C_STRUCTTYPE(XImage);IDAR0(CXImage)
INSTCCALL(CString)

NEWTYPE(HT(XFontProp));IPTR(XFontProp);ISTORE(HT(XFontProp));
INSTCCALL(HT(XFontProp));IDAR0(CXFontProp)

C_STRUCTTYPE(CXFontStruct);IDAR0(CCXFontStruct)
newCXFontStruct :: IO CCXFontStruct
newCXFontStruct = CDisplay -> CCXFontStruct
CCXFontStruct (CDisplay -> CCXFontStruct) -> IO CDisplay -> IO CCXFontStruct
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CDisplay -> IO CDisplay
forall a. Storable a => a -> IO CDisplay
mallocElem CDisplay
nullAddr
instance CVar CCXFontStruct CXFontStruct

C_STRUCTTYPE(CString);IDAR0(CCString)
newCString :: IO CCString
newCString = CDisplay -> CCString
CCString (CDisplay -> CCString) -> IO CDisplay -> IO CCString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CDisplay -> IO CDisplay
forall a. Storable a => a -> IO CDisplay
mallocElem CDisplay
nullAddr
instance CVar CCString CString
--- Constants -----------------------------------------------------------------
anyModifier :: Int
anyModifier = Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
15 :: Int)
grabModeAsync :: Int
grabModeAsync = Int
1 :: Int
--- Auxiliary functions/types -------------------------------------------------
call :: prim -> haskell
call prim
f = prim -> haskell
forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall prim
f
uio :: (a -> b) -> f a -> f b
uio a -> b
f = (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f

a2i :: Addr -> Int
a2i :: CDisplay -> Int
a2i CDisplay
a = CDisplay -> CDisplay -> Int
minusAddr CDisplay
a CDisplay
nullAddr

{-# NOINLINE i2a #-} -- Workaround a GHC bug on 64-bit systems /TH 2016-12-29
i2a :: Int -> Addr
i2a :: Int -> CDisplay
i2a = CDisplay -> Int -> CDisplay
plusAddr CDisplay
nullAddr

newtype DrawableId = DrawableId XID deriving Int -> DrawableId -> ShowS
[DrawableId] -> ShowS
DrawableId -> String
(Int -> DrawableId -> ShowS)
-> (DrawableId -> String)
-> ([DrawableId] -> ShowS)
-> Show DrawableId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DrawableId] -> ShowS
$cshowList :: [DrawableId] -> ShowS
show :: DrawableId -> String
$cshow :: DrawableId -> String
showsPrec :: Int -> DrawableId -> ShowS
$cshowsPrec :: Int -> DrawableId -> ShowS
Show
getdrawable :: Window -> Drawable -> DrawableId
getdrawable Window
_ (Pixmap (PixmapId XlibKeySym
i)) = XlibKeySym -> DrawableId
DrawableId XlibKeySym
i
getdrawable (WindowId XlibKeySym
w) Drawable
MyWindow = XlibKeySym -> DrawableId
DrawableId XlibKeySym
w
getdrawable Window
_ (DbeBackBuffer (DbeBackBufferId XlibKeySym
b)) = XlibKeySym -> DrawableId
DrawableId XlibKeySym
b

dcmap :: Display -> ColormapId -> IO ColormapId
dcmap Display
display ColormapId
cmap =
    if ColormapId
cmap ColormapId -> ColormapId -> Bool
forall a. Eq a => a -> a -> Bool
== ColormapId
defaultColormap
    then Display -> IO Int
xDefaultScreen Display
display IO Int -> (Int -> IO ColormapId) -> IO ColormapId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Display -> Int -> IO ColormapId
xDefaultColormap Display
display
    else ColormapId -> IO ColormapId
forall (m :: * -> *) a. Monad m => a -> m a
return ColormapId
cmap

data ByteOrder = LSBFirst | MSBFirst deriving (ByteOrder -> ByteOrder -> Bool
(ByteOrder -> ByteOrder -> Bool)
-> (ByteOrder -> ByteOrder -> Bool) -> Eq ByteOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByteOrder -> ByteOrder -> Bool
$c/= :: ByteOrder -> ByteOrder -> Bool
== :: ByteOrder -> ByteOrder -> Bool
$c== :: ByteOrder -> ByteOrder -> Bool
Eq,Int -> ByteOrder
ByteOrder -> Int
ByteOrder -> [ByteOrder]
ByteOrder -> ByteOrder
ByteOrder -> ByteOrder -> [ByteOrder]
ByteOrder -> ByteOrder -> ByteOrder -> [ByteOrder]
(ByteOrder -> ByteOrder)
-> (ByteOrder -> ByteOrder)
-> (Int -> ByteOrder)
-> (ByteOrder -> Int)
-> (ByteOrder -> [ByteOrder])
-> (ByteOrder -> ByteOrder -> [ByteOrder])
-> (ByteOrder -> ByteOrder -> [ByteOrder])
-> (ByteOrder -> ByteOrder -> ByteOrder -> [ByteOrder])
-> Enum ByteOrder
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ByteOrder -> ByteOrder -> ByteOrder -> [ByteOrder]
$cenumFromThenTo :: ByteOrder -> ByteOrder -> ByteOrder -> [ByteOrder]
enumFromTo :: ByteOrder -> ByteOrder -> [ByteOrder]
$cenumFromTo :: ByteOrder -> ByteOrder -> [ByteOrder]
enumFromThen :: ByteOrder -> ByteOrder -> [ByteOrder]
$cenumFromThen :: ByteOrder -> ByteOrder -> [ByteOrder]
enumFrom :: ByteOrder -> [ByteOrder]
$cenumFrom :: ByteOrder -> [ByteOrder]
fromEnum :: ByteOrder -> Int
$cfromEnum :: ByteOrder -> Int
toEnum :: Int -> ByteOrder
$ctoEnum :: Int -> ByteOrder
pred :: ByteOrder -> ByteOrder
$cpred :: ByteOrder -> ByteOrder
succ :: ByteOrder -> ByteOrder
$csucc :: ByteOrder -> ByteOrder
Enum)

--withLockedDisplay display cmd = cmd
{-
withLockedDisplay display cmd =
  do xLockDisplay display
     result <- cmd
     xUnlockDisplay display
     return result
-}