{-# LANGUAGE CPP #-} {- Obsolete OPTIONS -#include -#include -#include -fvia-C -} -- -optc-I/usr/X11R6/include module DoXRequest(doXRequest,getGCValues,translateCoordinates) where --import P_IO_data(Request(..),Response(..)) import Geometry import Command import Event import Xtypes import Font --import ResourceIds import Visual import HbcWord(intToWord) -- for Visual import IOUtil(getEnvi) --import CmdLineEnv(argFlag) import XCallTypes import StructFuns import Xlib import Marshall import MyForeign -- debugging import CString16 --import Ap {- #include "newstructfuns.h" -} newXID = newPtr :: IO CXID newLong = newPtr :: IO CLong newLongs n = sequence (replicate n newLong) readLong = readCVar :: CLong -> IO Int newInt32 = newPtr :: IO CInt32 newInt32s n = sequence (replicate n newInt32) readInt32 = readCVar :: CInt32 -> IO Int32 freePtrs xs = mapM_ freePtr xs --synchronize = argFlag "synchronize" False {- doXRequest req@(display,_,_) = do r <- doXRequest' req if synchronize && display/=noDisplay then xSync display False else return () return r -} {- doXRequest req@(display,_,_) | display/=noDisplay = withLockedDisplay display $ doXRequest' req doXRequest req = doXRequest' req -} doXRequest (d@display,wi,req) = case req of OpenDisplay optname -> do name <- if null optname then case getEnvi "DISPLAY" of Just n -> return n Nothing -> failu "DISPLAY variable is not set" else return optname d <- xOpenDisplay name --xSynchronize d synchronize -- has no effect?! return (DisplayOpened d) CreateSimpleWindow p r -> WindowCreated <$> createWindow wi r CreateRootWindow r resname -> WindowCreated <$> do dr <- xDefaultRootWindow display this <- createWindow dr r setClassHint display this resname "Fudgets" /* This is a hack that solves a focus problem with twm. The twm option NoTitleFocus also solves the problem. */ -- xSetWMHints display this InputHint True return this CreateGC dr oldgc gcattrs -> GCCreated <$> do wi' <- if wi == noWindow then xDefaultRootWindow display else return wi gcvals <- getGCValues gcattrs gc <- createGC display (getdrawable wi' dr) if oldgc == rootGC then do screen <- xDefaultScreen display xSetForeground display gc =<< xBlackPixel display screen xSetBackground display gc =<< xWhitePixel display screen else copyGC display oldgc gc changeGC display gc gcvals return gc LoadFont fn -> FontLoaded <$> xLoadFont display fn CreateFontCursor shp -> CursorCreated <$> xCreateFontCursor display shp GrabPointer b evm -> PointerGrabbed <$> xGrabPointer display wi b (toC evm) grabModeAsync grabModeAsync windowNone cursorNone currentTime AllocNamedColor cm cn -> ColorAllocated <$> (allocNamedColor display cn =<< dcm cm) AllocColor cm rgb -> ColorAllocated <$> (allocColor display rgb =<< dcm cm) CreatePixmap (Point w h) depth -> PixmapCreated <$> do depth' <- if depth == copyFromParent then xDefaultDepth display =<< xDefaultScreen display else return depth WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi xCreatePixmap display (DrawableId wi') w h depth' ReadBitmapFile filename -> do bm <- newXID ints@[w,h,xhot,yhot] <- newInt32s 4 WindowId root <- xDefaultRootWindow display cfilename <- marshallString filename -- GHC gives faulty code for marshallM? --putStrLn "about to call xReadBitmapFile" --writeCVar xhot 0 --putStrLn filename --putStrLn =<< unmarshall cfilename --print =<< readLong xhot r <- xReadBitmapFile display (DrawableId root) cfilename w h bm xhot yhot --putStrLn "returned from call to xReadBitmapFile" freePtr cfilename -- crash?!! --putStrLn "about to read xhot" x <- fromIntegral <$> readInt32 xhot --putStr "xhot =";print x ret <- if (r::Int) == CCONST(BitmapSuccess) then do hot <- if x == -1 then return Nothing else Just . Point x . fromIntegral <$> readInt32 yhot BitmapReturn <$> (Point <$> (fromIntegral <$> readInt32 w) <*> (fromIntegral <$> readInt32 h)) <*> return hot <*> (PixmapId <$> readCVar bm) else return BitmapBad --putStrLn "about to free int parameters" freePtrs ints freePtr bm return (BitmapRead ret) CreateBitmapFromData (BitmapData size@(Point w h) hot bytes) -> do cbytes <- marshallString' (map toEnum bytes) (((w+7) `div` 8)*h) WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi let cw = fromIntegral w ch = fromIntegral h pm <- xCreateBitmapFromData display (DrawableId wi') cbytes cw ch freePtr cbytes return (BitmapRead (BitmapReturn size hot pm)) --RmGetStringDatabase str -> --RmGetResource rmd s1 s2 -> TranslateCoordinates -> do rootwin <- xDefaultRootWindow display CoordinatesTranslated . maybe origin id <$> translateCoordinates display wi rootwin InternAtom str b -> GotAtom <$> xInternAtom display str b GetAtomName a -> do at_ret <- xGetAtomName display a if (at_ret == nullStr) then return (GotAtomName Nothing) else do at_name <- unmarshallString at_ret xFree at_ret -- putStrLn at_name case (length at_name) of 0 -> return (GotAtomName Nothing) _ -> return (GotAtomName $ Just at_name) GetWindowProperty offset property delete req_type -> do let length = 1000 actual_type <- newPtr actual_format <- newPtr nitems <- newLong bytes_after <- newLong prop_return <- newCString xGetWindowProperty display wi property offset (length `div` (4::Int)) delete req_type actual_type actual_format nitems bytes_after prop_return at <- readCVar actual_type af <- readCVar actual_format n <- readLong nitems ba <- readLong bytes_after str <- if (af::Int) == CCONST(None) then return "" else do let got = af*n `div` 8 cstr <- readCVar prop_return str <- unmarshallString' cstr got xFree cstr return str freePtr actual_type freePtr actual_format freePtr nitems freePtr bytes_after freePtr prop_return return $ GotWindowProperty at af n ba str QueryPointer -> do ints@[root,child,root_x,root_y,win_x,win_y,mask] <- newLongs 7 same <- xQueryPointer display wi root child root_x root_y win_x win_y mask ret <- PointerQueried same <$> mkPoint (readLong root_x) (readLong root_y) <*> mkPoint (readLong win_x) (readLong win_y) <*> (fromC <$> readLong mask) freePtrs ints return ret QueryFont fid -> FontQueried <$> queryFont display fid LoadQueryFont fn -> FontQueried <$> loadQueryFont display fn QueryColor cmid (Pixel px) -> do c <- newXColor SET(XColor,Word,c,pixel,px) cm <- dcm cmid xQueryColor display cm c r <- mkColor c freePtr c return (ColorQueried r) ListFonts pattern maxnames -> do cnt <- newLong fnarr <- xListFonts display pattern maxnames cnt fns <- unmarshallArray fnarr =<< readLong cnt xFreeFontNames fnarr freePtr cnt return (GotFontList fns) --QueryTree -> DefaultRootWindow -> GotDefaultRootWindow <$> xDefaultRootWindow display --GetGeometry -> --GetResource rms -> DefaultVisual -> GotVisual <$> (mkVisual =<< xDefaultVisual d =<< xDefaultScreen d) Sync b -> xSync display b >> return Synced QueryTextExtents16 fid s -> do let n = length s cs <- marshallString16' s n ints@[dir,ascent,descent,overall] <- newLongs 4 overall <- newPtr xQueryTextExtents16 display fid cs n dir ascent descent overall [asc,desc] <- mapM readLong [ascent,descent] ov <- mkCharStruct overall freePtrs ints freePtr overall return $ TextExtents16Queried asc desc ov ListFontsWithInfo pattern maxnames -> GotFontListWithInfo <$> listFontsWithInfo d pattern maxnames DbeQueryExtension -> do ints@[major,minor] <- newLongs 2 status <- xdbeQueryExtension display major minor ma <- readLong major mi <- readLong minor freePtrs ints return (DbeExtensionQueried status ma mi) DbeAllocateBackBufferName swapAction -> DbeBackBufferNameAllocated <$> xdbeAllocateBackBufferName d wi swapAction DbeSwapBuffers swapAction -> -- applies only to the fudget's own window. do (swapinfo,cnt) <- storeSwapAction [(wi,swapAction)] status <- xdbeSwapBuffers display swapinfo cnt freePtr swapinfo return (DbeBuffersSwapped status) _ -> error (notImplemented req) where createWindow parent (Rect (Point x y) (Point w h)) = do screen <- xDefaultScreen display blackP <- xBlackPixel display screen whiteP <- xWhitePixel display screen let border_width = 0 -- should agree with border_width in WindowF.hs !! this <- xCreateSimpleWindow display parent x y w h border_width blackP whiteP xStoreName display this "Fudgets" return this dcm = dcmap display {- type BorderWidth = Int type FontShape = Int -} setClassHint :: Display -> Window -> String -> String -> IO () setClassHint d w resName resClass = do class_hints <- newPtr rn<-marshallString resName SET(XClassHint,CString,class_hints,res_name,rn) rc<-marshallString resClass SET(XClassHint,CString,class_hints,res_class,rc) xSetClassHint d w class_hints freePtr rn freePtr rc createGC :: Display -> DrawableId -> IO GCId createGC d w = xCreateGC d w 0 nullPtr -- _casm_ ``%r=XCreateGC(%0,%1,0,NULL);'' d w copyGC :: Display -> GCId -> GCId -> IO () copyGC d oldgc gc = --xCopyGC d oldgc ``(1<<(GCLastBit+1))-1)''gc xCopyGC d oldgc 8388607 gc -- _casm_ ``XCopyGC(%0,%1,(1<<(GCLastBit+1))-1,%2);'' d oldgc gc changeGC d gc (gcvals,mask) = xChangeGC d gc mask gcvals allocNamedColor :: Display -> String -> ColormapId -> IO (Maybe Color) allocNamedColor d colname cm = do exact <- newPtr screen <- newPtr status <- xAllocNamedColor d cm colname screen exact r <- returnColor status screen freePtr exact freePtr screen return r returnColor status c = if status /= (0::Int) then Just <$> mkColor c else return Nothing mkColor xcol = Color . Pixel <$> GET(XColor,Word,xcol,pixel) <*> (RGB <$> GET(XColor,Int,xcol,red) <*> GET(XColor,Int,xcol,green) <*> GET(XColor,Int,xcol,blue) ) allocColor :: Display -> RGB -> ColormapId -> IO (Maybe Color) allocColor d rgb cm = do color <- newXColor setRGB rgb color status <- xAllocColor d cm color r <- returnColor status color freePtr color return r setRGB (RGB red green blue) color = do SET(XColor,Int,color,red,red) SET(XColor,Int,color,green,green) SET(XColor,Int,color,blue,blue) type XGCValuesMask = (CXGCValues,Bitmask) getGCValues :: GCAttributeList -> IO XGCValuesMask getGCValues = getValues newPtr getGCValue where getGCValue gcv ga = case ga of GCFunction f -> (SET(XGCValues,Int,gcv,function,fromEnum f),CWORD32(GCFunction)::Bitmask) GCForeground p -> (SET(XGCValues,Int,gcv,foreground,toC p),CWORD32(GCForeground)) GCBackground p -> (SET(XGCValues,Int,gcv,background,toC p),CWORD32(GCBackground)) GCLineWidth w -> (SET(XGCValues,Int,gcv,line_width,w),CWORD32(GCLineWidth)) GCLineStyle s -> (SET(XGCValues,Int,gcv,line_style,fromEnum s),CWORD32(GCLineStyle)) GCFont f -> (SET(XGCValues,XID,gcv,font,toXID f),CWORD32(GCFont)) GCCapStyle s -> (SET(XGCValues,Int,gcv,cap_style,fromEnum s),CWORD32(GCCapStyle)) GCJoinStyle s -> (SET(XGCValues,Int,gcv,join_style,fromEnum s),CWORD32(GCJoinStyle)) GCSubwindowMode m -> (SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m),CWORD32(GCSubwindowMode)) GCGraphicsExposures g -> (SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g),CWORD32(GCGraphicsExposures)) GCFillStyle f -> (SET(XGCValues,Int,gcv,fill_style,fromEnum f),CWORD32(GCFillStyle)) GCTile p -> (SET(XGCValues,XID,gcv,tile,toXID p),CWORD32(GCTile)) GCStipple p -> (SET(XGCValues,XID,gcv,stipple,toXID p),CWORD32(GCStipple) :: Bitmask) -- _ -> (return (),0) loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList) loadQueryFont d fn = mkFontStructList =<< xLoadQueryFont d fn queryFont :: Display -> FontId -> IO (Maybe FontStructList) queryFont d fi = mkFontStructList =<< xQueryFont d fi listFontsWithInfo :: Display -> FontName -> Int -> IO [(FontName,FontStructList)] listFontsWithInfo d pattern maxnames = do cnt <- newInt32 fsarrp <- newCXFontStruct --putStrLn "About to call xListFontsWithInfo" fnarr <- xListFontsWithInfo d pattern (fromIntegral maxnames) cnt fsarrp --putStrLn "Returned from call xListFontsWithInfo" n <- readInt32 cnt --putStr "Number of fonts: " ; print n freePtr cnt fsarr <- readCVar fsarrp freePtr fsarrp --putStrLn "After free fsarrp" if fnarr==nullStr then return [] else do --putStrLn "Non-null name array" fns <- unmarshallArray fnarr (fromIntegral n) --putStrLn "Got name list";print fns fss <- readArray fsarr (fromIntegral n) --putStrLn "Got fontstruct list" xFreeFontInfo fnarr fsarr n --putStrLn "Freed fontinfo, returning" return (zip fns fss) instance CVar CXFontStruct FontStructList instance Storable FontStructList where -- just for readArray... --sizeOf _ = sizeOf (undefined::CXFontStruct) -- Wrong size!!! sizeOf _ = SIZEOF(XFontStruct) alignment _ = alignment (undefined::CXFontStruct) peek = mkFontStructList' . CXFontStruct mkFontStructList :: CXFontStruct -> IO (Maybe FontStructList) mkFontStructList fs = if fs == CXFontStruct nullAddr then return Nothing else do fsl <- mkFontStructList' fs --_casm_ ``XFreeFontInfo(NULL, %0, 1); '' fs xFreeFontInfo nullStr fs 1 return (Just fsl) #if 0 #define DEBUG(cmd) (putStrLn "cmd before">>(cmd)>>= \r->putStrLn "after">>return r) #else #define DEBUG(cmd) (cmd) #endif mkFontStructList' :: CXFontStruct -> IO FontStructList mkFontStructList' fs = do --putStrLn "Enter mkFontStructList'" min_char_or_byte2 <- GET(XFontStruct,Int,fs,min_char_or_byte2) min_byte1 <-GET(XFontStruct,Int,fs,min_byte1) max_char_or_byte2 <- GET(XFontStruct,Int,fs,max_char_or_byte2) max_byte1 <-GET(XFontStruct,Int,fs,max_byte1) n_prop <-GET(XFontStruct,Int,fs,n_properties) -- putStrLn $ "font properties: " ++ (show n_prop) --putStrLn "after min max" let min = min_char_or_byte2 + 256*min_byte1 max = max_char_or_byte2 + 256*max_byte1 arrsize = (max_char_or_byte2 - min_char_or_byte2 + 1) * (max_byte1 - min_byte1 + 1) --arrsize = max - min :: Int -- This is wrong! --print ("min max arrsize",min,max,arrsize) per_char <- GET(XFontStruct,HT(XCharStruct),fs,per_char) --putStrLn "after per_char" elem9 <- if per_char /= nullPtr -- CCONST(NULL) then Just <$> mapM (\i -> INDEX(XCharStruct) per_char i >>= mkCharStruct) [0..arrsize-1] else return Nothing --putStrLn "after elem9" f_prop <- GET(XFontStruct,HT(XFontProp),fs,properties) elemprop <- if f_prop /= nullPtr then mapM (\i -> INDEX(XFontProp) f_prop i >>= mkFontProp) [0..n_prop-1] else return [] -- putStrLn $ show elemprop fsl <- FontStruct . FontId <$> DEBUG(GET(XFontStruct,XID,fs,fid)) <*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,direction)) <*> return (toEnum min) <*> return (toEnum max) <*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,all_chars_exist)) <*> DEBUG(GET(XFontStruct,Char,fs,default_char)) <*> return elemprop <*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,min_bounds))) <*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,max_bounds))) <*> return elem9 <*> DEBUG(GET(XFontStruct,Int,fs,ascent)) <*> DEBUG(GET(XFontStruct,Int,fs,descent)) -- putStrLn $ "Returning from mkFontStructList'" ++ (show fsl) return fsl -- Intermediate data for FontProp, containing just two integers: -- atom values will (hopefully) be retrieved lazily. mkFontProp :: CXFontProp -> IO FontProp mkFontProp fp = FontProp <$> GET(XFontProp,Atom,fp,name) <*> GET(XFontProp,Int,fp,card32) mkCharStruct :: CXCharStruct -> IO CharStruct mkCharStruct cs = CharStruct <$> GET(XCharStruct,Int,cs,lbearing) <*> GET(XCharStruct,Int,cs,rbearing) <*> GET(XCharStruct,Int,cs,width) <*> GET(XCharStruct,Int,cs,ascent) <*> GET(XCharStruct,Int,cs,descent) mkVisual :: CVisual -> IO Visual mkVisual cv = Visual <$> GET(Visual,VisualID,cv,visualid) <*> fmap toEnum GET(Visual,Int,cv,class) <*> fmap intToWord GET(Visual,Int,cv,red_mask) <*> fmap intToWord GET(Visual,Int,cv,green_mask) <*> fmap intToWord GET(Visual,Int,cv,blue_mask) <*> GET(Visual,Int,cv,bits_per_rgb) <*> GET(Visual,Int,cv,map_entries) storeSwapAction :: [(WindowId,SwapAction)] -> IO (CXdbeSwapInfoArray,Int) storeSwapAction = getArray newXdbeSwapInfoArray (\si (i,(wi,sa)) -> do SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi) SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa)) translateCoordinates display window dstwindow = do dx <- newPtr dy <- newPtr child <- newPtr ok <- xTranslateCoordinates display window dstwindow 0 0 dx dy child p <- if ok then Just <$> (Point <$> (fromEnum <$> readInt32 dx) <*> (fromEnum <$> readInt32 dy)) else return Nothing freePtrs [dx,dy] freePtr child return p