-- | This is an implementation of the X Window System Protocol, -- , -- inspired by . -- It is designed to provide a type-safe, Xlib-like API and to cover the -- parts expected by Fudgets. module X11( -- ** Display xOpenDefaultDisplay,xOpenDisplay,xListExtensions,xQueryExtension, Display,displayName,bitmapUnit,bitmapPad,maxRequestLength, keycodeMinMax,screens,pmFormats, screen,Screen(..),PixmapFormat(..),defaultVisual, -- ** Mouse and keyboard xGetKeyboardMapping,xGetModifierMapping, xGrabButton,xUngrabButton, -- ** Window xCreateWindow,xCreateWindow',xChangeWindowAttributes,xConfigureWindow, xChangeProperty,xStoreName,xMapWindow,xUnmapWindow,xDestroyWindow, -- ** Color xAllocNamedColor,xAllocColor, -- ** Font xLoadFont,xQueryFont,xListFontsWithInfo,xQueryTextExtents16, -- ** GC xCreateGC,xCreateGC',xChangeGC,xCopyGC,xFreeGC, -- ** Atom xInternAtom,xGetAtomName, -- ** Cursor xCreateGlyphCursor, -- ** Drawing xClearArea, xCreatePixmap,xFreePixmap,xPutImage,xCopyPlane,xCopyArea, xDrawImageString,xDrawString16,xDrawImageString16, xDrawPoints,xDrawArc,xFillArc,xDrawLine,xDrawLines,xFillPolygon, xDrawRectangle,xFillRectangle, -- ** Misc xBell,xNoOperation,xFlush, -- ** Extensions xShapeCombineMask, xdbeQueryExtension,xdbeAllocateBackBufferName,xdbeSwapBuffers, -- ** Events xNextEvent,xWaitForEvent,xEventsQueued,xSelect, -- ** Types Drawable,Window,Pixmap,DbeBackBufferId,Extension,present, Atom,Colormap,RGB(..),Color(..), Fontable,Font,GC, Cursor,Keycode,Keysym, Pixel(..),Point,Line(..),Rect(..),EventMask(..), ) where import Control.Monad(when,replicateM) import System.IO(hPutStrLn,stderr) --import System.IO(Handle,hSetBuffering,BufferMode(..),hWaitForInput) --,hReady import SocketIO(Socket,select,sRead,sWrite,connectTo,PortID(..),s2fd) import System.Environment(getEnv) --import Data.Int(Int16) import Data.Word import Data.Function(on) import Data.List(sortOn,nubBy) import qualified Data.ByteString as B import Data.IORef(IORef,newIORef,readIORef,writeIORef,modifyIORef) import Data.Bits((.|.),(.&.))--,shiftR import Queue as Q import EventMask(EventMask(..)) import qualified Xtypes as F(WindowAttributes(..),WindowChanges(..),XID(..), CursorId(..),Pixel(..),GCAttributeList,GCAttributes(..),FontId(..), RGB(..),PropertyMode(..),propModeReplace,Atom(..),PixmapId(..), Modifiers(..),ImageFormat(..),ClientData(..), ShapeKind,ShapeOperation,SwapAction, CharStruct(..),FontStructF(..),FontProp(..),Shape,CoordMode) import Visual import X11Types import X11Utils import X11Event import X11Auth import qualified X11Error as E import Debug.Trace default (Int) debug = hPutStrLn stderr dPrint x = debug (show x) xOpenDefaultDisplay = xOpenDisplay =<< getEnv "DISPLAY" xOpenDisplay displayName = initiateConnection =<< connectTo host port where (host,port,displayNumber) = case hn displayName of ("",d) -> ("",UnixSocket $ "/tmp/.X11-unix/X"++d,d) ('/':_,d) -> ("",UnixSocket displayName,d) (host,d) -> (host,PortNumber (6000+fi (read d)),d) hn dn = case break (==':') dn of (host,':':ds) -> (host,n) where n = takeWhile (/='.') ds -- drop screen number useAuth --{- | take 1 displayName/="/" = do auth <- findAuth host displayNumber return $ case auth of [Xauth{name=n,auth_data=a}] -> (n,a) --n=="MIT-MAGIC-COOKIE-1"? _ -> ("","") --} | otherwise = return ("","") initiateConnection d = do (aprot,adata) <- useAuth --dPrint (aprot,adata) --hSetBuffering d NoBuffering let initReq = packet $ put [c2w 'l',0]<> putWord16x2 (11,0)<> putWord16x2 (fi n,fi d)<> putWord16 0<> putStr8pad (pad n) aprot<> putStr8pad (pad d) adata where n = length aprot d = length adata sWrite d initReq r1 <- sGet d 8 when (B.length r1<8) $ fail $ "Short reply: "++show r1 let rs = byte r1 0 additionalDataLength = word16 r1 6 r <- B.append r1 <$> sGet d (4*additionalDataLength) case rs of 1 -> return () 2 -> fail "Authentication not implemented" 0 -> do let (ver,reason) = getFrom r $ do unused 1 n <- fi <$> w8 ver <- two w16 unused 2 reason <- string8 n return (ver,reason) fail $ "Error in xOpenDisplay: "++show ver++" "++reason _ -> fail ("Unexpected response: "++show rs) --print additionalDataLength --print (B.length r) let (display1,version,vr) = getFrom r $ do unused 2 version <- two w16 unused 2 -- additional data length release <- w32 -- release-number (base,mask) <- get -- resource ids unused 4 -- motion-buffer-size lengthOfVendor <- fi <$> w16 maxrql <- fi <$> w16 -- max-request-length n <- fi <$> w8 -- number of screens numberOfFormats <- fi <$> w8 imageByteOrder <- w8 bitMapFormatBitOrder <- w8 (bitmapUnit,bitmapPad) <- two (fi<$>w8) keycodeMinMax <- get unused 4 -- unused vendor <- string8 lengthOfVendor unused (pad lengthOfVendor) formats <- list numberOfFormats get screens <- list n get return (Display d base mask maxrql bitmapUnit bitmapPad keycodeMinMax displayName screens formats undefined undefined, version,(vendor,release)) display <- display1 <$> newIORef 0 <*> newIORef Q.empty --debug "Version: ";dPrint version; --dPrint vr --debug "Resource base,mask: "; dPrint (base display,mask display) shape <- xQueryExtension display "SHAPE" dbe <- xQueryExtension display "DOUBLE-BUFFER" enableBigRequests display{shapeExt=shape,dbeExt=dbe} -- https://www.x.org/releases/X11R7.7/doc/bigreqsproto/bigreq.html enableBigRequests display = do big <- xQueryExtension display "BIG-REQUESTS" if present big then do maxrql <- bigRequestEnable big return $ if maxrql>0 then display{maxRequestLength=maxrql} else display else return display where bigRequestEnable big = do putR' "BigRequestEnable" display (majorOpCode big) 0 1 nil parseReply display $ do unused 8; w32 -------------------------------------------------------------------------------- data Display = Display { socket::Socket, base,mask::Word32, maxRequestLength::Word32, bitmapUnit,bitmapPad::Int, keycodeMinMax::(Keycode,Keycode), displayName::String, screens::[Screen], pmFormats::[PixmapFormat], shapeExt,dbeExt::Extension, globalId::IORef Word32, eventQ::IORef (QUEUE Event) } screen = head . screens --connectionNumber = socket data Screen = Screen { rootWindowId::Window, defaultColormap::Colormap, whitePixel,blackPixel::Pixel, screenSize,screenSizeMM::(Word16,Word16), rootVisualId::VisualID, rootDepth::Word8, allowedDepths::[(Word8,[Visual])] } deriving Show data PixmapFormat = PF { depth,bpp,scanlinePad::Word8 } deriving Show defaultVisual = defaultVisualOfScreen . screen defaultVisualOfScreen screen = head [v | (d,vs)<-allowedDepths screen, d==rootDepth screen, v<-vs, visualid v==rootVisualId screen] instance FromX Screen where get = Screen <$> get -- rootWindowId <*> get -- defaultColormap <*> get -- whitePixel <*> get -- blackPixel <* unused 4 -- current event mask <*> get -- with & hight in pixels <*> get -- width & heigh in millimeters <* unused 4 -- min max installed maps <*> get -- rootVisualId <* unused 2 -- backing-stores, save-unders <*> get -- root depth <*> allowedDepths where allowedDepths = do n <- fi <$> w8 -- number of depths in allowed-depths list n depth depth = do d <- w8 -- depth unused 1 -- unused n <- fi <$> w16 -- number of visual types unused 4 -- unused (,) d <$> list n visualType visualType = visual <$> get -- visual-id <*> (convEnum <$> w8) -- class <*> w8 -- bits-per-rgb-value <*> w16 -- colormap-entries <*> w32 -- red-mask <*> w32 -- green-mask <*> w32 -- bluemask <* unused 4 -- unused where visual vid cls bprgb cme rm gm bm = Visual vid cls (fi rm) (fi gm) (fi bm) (fi bprgb) (fi cme) instance FromX PixmapFormat where get = PF <$> w8 <*> w8 <*> w8 <* unused 5 instance FromX Colormap where get = Colormap <$> get instance FromX VisualID where get = VisualID . fi <$> w32 -------------------------------------------------------------------------------- dPut d r = do --n <- queueEvents d --when (n>0) $ do debug $ "Queued "++show n++" event(s)" sWrite (socket d) r return () --dFlush = hFlush . socket xFlush d = return () -- no buffering, nothing to flush dGet d n = do r <- sGet (socket d) n when (B.null r) (fail "Connection closed?") return r sGet s n = B.concat <$> get n where get 0 = return [] get n = do b <- sRead s (fi n) if B.null b then return [] else (b:) <$> get (n-B.length b) getNextId d = do gid <- succ <$> readIORef (globalId d) writeIORef (globalId d) gid return ((mask d .&. gid) .|. base d) -------------------------------------------------------------------------------- pad n = (4 - (n `mod` 4)) `mod` 4 data X11Request = CreateWindow | ChangeWindowAttributes | GetWindowAttributes | DestroyWindow | DestroySubwindows | ChangeSaveSet | ReparentWindow | MapWindow | MapSubwindows | UnmapWindow | UnmapSubwindows | ConfigureWindow | CirculateWindow | GetGeometry | QueryTree | InternAtom | GetAtomName | ChangeProperty | DeleteProperty | GetProperty | ListProperties | SetSelectionOwner | GetSelectionOwner | ConvertSelection | SendEvent | GrabPointer | UngrabPointer | GrabButton | UngrabButton | ChangeActivePointerGrab | GrabKeyboard | UngrabKeyboard | GrabKey | UngrabKey | AllowEvents | GrabServer | UngrabServer | QueryPointer | GetMotionEvents | TranslateCoordinates | WarpPointer | SetInputFocus | GetInputFocus | QueryKeymap | OpenFont | CloseFont | QueryFont | QueryTextExtents | ListFonts | ListFontsWithInfo | SetFontPath | GetFontPath | CreatePixmap | FreePixmap | CreateGC | ChangeGC | CopyGC | SetDashes | SetClipRectangles | FreeGC | ClearArea | CopyArea | CopyPlane | PolyPoint | PolyLine | PolySegment | PolyRectangle | PolyArc | FillPoly | PolyFillRectangle | PolyFillArc | PutImage | GetImage | PolyText8 | PolyText16 | ImageText8 | ImageText16 | CreateColormap | FreeColormap | CopyColormapAndFree | InstallColormap | UninstallColormap | ListInstalledColormaps | AllocColor | AllocNamedColor | AllocColorCells | AllocColorPlanes | FreeColors | StoreColors | StoreNamedColor | QueryColors | LookupColor | CreateCursor | CreateGlyphCursor | FreeCursor | RecolorCursor | QueryBestSize | QueryExtension | ListExtensions | ChangeKeyboardMapping | GetKeyboardMapping | ChangeKeyboardControl | GetKeyboardControl | Bell | ChangePointerControl | GetPointerControl | SetScreenSaver | GetScreenSaver | ChangeHosts | ListHosts | SetAccessControl | SetCloseDownMode | KillClient | RotateProperties | ForceScreenSaver | SetPointerMapping | GetPointerMapping | SetModifierMapping | GetModifierMapping --- | NoOperation deriving (Show,Enum,Bounded) opcode NoOperation = 127 opcode request = 1+convEnum request request 127 = Just NoOperation request n | 1<=n && n<=opcode GetModifierMapping = Just (toEnum (n-1)) request _ = Nothing windowClass_InputOutput = 1 -------------------------------------------------------------------------------- putR d rq = putR' (show rq) d (opcode rq) putR' o d rq b1 rl bs | B.length send == fromEnum (rl'*4) = do --dPrint (o,rl); dPut d send | otherwise = error $ "Request length mismatch for "++o++" request" ++": "++show (rl*4,B.length send) where (rl',send) | rl<=65535 = (rl,packet (put rq<>putWord8 b1<>putWord16 (fi rl)<>bs)) | rlput b1<>putWord16 0<>putWord32 (rl+1)<>bs)) | otherwise = error $ "Request too big for "++o++" request: "++ show rl++" > "++show (maxRequestLength d) putDrGc dr (GC gc) = put (drawable dr,gc) putDr d dr gc rq b1 rl bs = putR d rq b1 rl (putDrGc dr gc<>bs) -------------------------------------------------------------------------------- xCreateWindow display window r bw (Pixel bg) eventmask = xCreateWindow' display window r bw [F.CWBackPixel (F.Pixel (convEnum bg)), F.CWEventMask eventmask] xCreateWindow' display (Window parent) r@R{} bw values = do windowId <- getNextId display let depth = 0 -- CopyFromParent (mvs,n) = valuesMask (values::[F.WindowAttributes]) reqLength = 8+n putR display CreateWindow depth reqLength $ put (windowId,parent)<> put r<> putWord16 bw<> putWord16 windowClass_InputOutput<> put (rootVisualId (screen display))<> put mvs return (Window windowId) xDestroyWindow display (Window wid) = putR display DestroyWindow 0 2 $ putWord32 wid xChangeWindowAttributes display (Window wid) values = do let (mvs,n) = valuesMask (values::[F.WindowAttributes]) reqLength = 3+n putR display ChangeWindowAttributes 0 reqLength $ put (wid,mvs) xConfigureWindow display (Window wid) values = do let (mvs,n) = valuesMask (values::[F.WindowChanges]) reqLength = 3+n putR display ConfigureWindow 0 reqLength $ put (wid,mvs) xMapWindow display (Window wid) = putR display MapWindow 0 2 $ putWord32 wid xUnmapWindow display (Window wid) = putR display UnmapWindow 0 2 $ putWord32 wid xLoadFont display fontname = do fontId <- getNextId display let len = toEnum (length fontname) padded = pad len requestLength = 3 + (len + padded) `div` 4; putR display OpenFont 0 requestLength $ putWord32 fontId<> putWord16' len<> putWord16 0<> putStr8pad padded fontname return (Font fontId) xQueryFont display (Font fid) = do putR display QueryFont 0 2 $ putWord32 fid parseReply display $ do let fontId = F.FontId (F.XID (fi fid)) fontOverall fontId (\m->Just <$> list (fi m) getCharStruct) xQueryTextExtents16 display fid text = do let n2 = toEnum (2*length text) p = pad n2 reqLen = 2+(n2+p) `quot` 4 putR display QueryTextExtents (b2w (p==2)) reqLen $ putWord32 (fontable fid)<> putStr16pad p text parseReply display $ do unused 8 fafd <- two (fromEnum <$> i16) (a,d) <- two (fi <$> i16) w <- fi <$> i32 (l,r) <- two (fi <$> i32) unused 4 return (fafd,F.CharStruct l r w a d) xListFontsWithInfo display pattern maxNames = do let n = toEnum (length pattern) p = pad n reqLen = 2+(n+p) `quot` 4 putR display ListFontsWithInfo 0 reqLen $ putWord16 maxNames<> putWord16' n<> putStr8pad p pattern getReplies where getReplies = do r <- getReply display let n = byte r 1 if n==0 then return [] else (:) (getFrom r (fontWithInfo n)) <$> getReplies fontWithInfo n = do let fid = trace "FontId not provided by xListFontsWithInfo" $ F.FontId (F.XID 0) fs <- fontOverall fid (\n->return Nothing) name <- string8 n return (name,fs) fontOverall fid details = do unused 8 (minBounds,maxBounds) <- two (get <* unused 4) (minChar,maxChar) <- two (convEnum <$> w16) defaultChar <- convEnum <$> w16 m <- w16 -- number of fontprops dir <- convEnum <$> w8 (minByte1,maxByte1) <- two w8 complete <- get (fa,fd) <- two (fi<$>i16) count <- w32 props <- list (fi m) get charinfo <- details count return (F.FontStruct fid dir minChar maxChar -- !! complete defaultChar props maxBounds minBounds charinfo fa fd) instance FromX F.FontProp where get = F.FontProp <$> get <*> (fi<$>w32) instance FromX F.Atom where get = F.Atom .fi<$>w32 instance FromX F.CharStruct where get = getCharStruct getCharStruct = F.CharStruct <$> i <*> i <*> i <*> i <*> i <* w16 where i = fi <$> i16 xCreatePixmap display (Window w) sz depth = do pid <- getNextId display putR display CreatePixmap depth 4 $ putWord32 pid<> putWord32 w<> putWord16x2 sz return (Pixmap pid) xFreePixmap display (Pixmap pm) = putR display FreePixmap 0 2 $ put pm xCreateGC display dr fg bg (Font fontId) = xCreateGC' display dr [F.GCForeground (pixel fg),F.GCBackground (pixel bg), F.GCFont (F.FontId (F.XID (fromEnum fontId)))] where pixel (Pixel p) = F.Pixel (convEnum p) xCreateGC' display dr values = do gcId <- getNextId display let (mvs,n) = valuesMask (values::F.GCAttributeList) requestLength = 4 + n putR display CreateGC 0 requestLength $ put (gcId,drawable dr,mvs) return (GC gcId) xFreeGC display (GC gc) = putR display FreeGC 0 2 $ putWord32 gc xChangeGC display (GC gcId) values = putR display ChangeGC 0 requestLength $ put (gcId,mvs) where (mvs,n) = valuesMask (values::F.GCAttributeList) requestLength = 3 + n xCopyGC display (GC srcgc) (GC dstgc) = putR display CopyGC 0 4 $ put (srcgc,dstgc)<> putWord32 0x007fffff -- copy all values xClearArea display (Window wid) rect@R{} exposures = putR display ClearArea (b2w exposures) 4 $ put (wid,rect) xCopyArea display sdr ddr (GC gc) (R x y w h) dst = putR display CopyArea 0 7 $ put (drawable sdr,drawable ddr)<> put gc<> put (x,y)<> putInt16x2 dst<> put (w,h) xCopyPlane display sdr ddr (GC gc) (R x y w h) dst plane = putR display CopyPlane 0 8 $ put (drawable sdr,drawable ddr)<> put gc<> put (x,y)<> putInt16x2 dst<> put (w,h)<> putWord32 plane xDrawString16 display dr gc xy text | m<255 = putDr display dr gc PolyText16 0 requestLen $ putInt16x2 xy<> putWord8x2 (convEnum m,0)<> putStr16pad p text where m = toEnum (length text) n = 2+2*m p = pad n requestLen = 4+(n+p) `quot` 4 xDrawImageString16 display dr gc xy text | n<=255 = putDr display dr gc ImageText16 (fi n) reqLen $ putInt16x2 xy<> putStr16pad p text where n = toEnum (length text) p = pad (2*n) reqLen = 4+(2*n+p) `quot` 4 xDrawImageString display dr gc (x,y) text | len<=255 = putDr display dr gc ImageText8 (fi len) reqLen $ putInt16x2 (x,y)<> putStr8pad p text where len = toEnum (length text) p = pad len reqLen = 4 + (len + p) `div` 4; xDrawLine display dr gc l@L{} = putDr display dr gc PolySegment 0 contentLength $ put l where n = 1 contentLength = 3+2*n xDrawPoints display dr gc ps = putDr display dr gc PolyPoint 0 reqLen $ put (ps::[Point]) where n = toEnum (length ps) reqLen = 3+n xDrawLines display dr gc ps cm = putDr display dr gc PolyLine mode reqLen $ put (ps::[Point]) where mode = convEnum (cm::F.CoordMode) n = toEnum (length ps) reqLen = 3+n xFillPolygon display dr gc ps sh cm = putDr display dr gc FillPoly 0 requestLen $ putBytes [convEnum (sh::F.Shape), convEnum (cm::F.CoordMode)]<> putWord16 0<> put (ps::[Point]) where n = toEnum (length ps) requestLen = 4+n xDrawRectangle d = doRectangle PolyRectangle d xFillRectangle d = doRectangle PolyFillRectangle d doRectangle req display dr gc r@R{}= putDr display dr gc req 0 contentLength $ put r where n = 1 contentLength = 3+2*n xDrawArc d = drawArc PolyArc d xFillArc d = drawArc PolyFillArc d drawArc req display dr gc r@R{} a1 a2 = putDr display dr gc req 0 contentLength $ put r<> putInt16x2 (a1,a2) where n = 1 contentLength = 3+3*n xPutImage display dr gc depth size dst (F.ImageFormat fmt) pxls = do let bs = put pxls n = toEnum (B.length (packet bs)) -- !! p = pad n requestLen = 6+(n+p) `quot` 4 putDr display dr gc PutImage (toEnum fmt) requestLen $ putWord16x2 size<> putInt16x2 dst<> putBytes [0,depth,0,0]<> bs<> padding p xInternAtom display atomName ifExists = do let n = toEnum (length atomName) p = pad n requestLength = 2 + (n+p) `quot` 4 putR display InternAtom (b2w ifExists) requestLength $ putWord16' n<> putWord16 0<> putStr8pad p atomName parseReply display $ Atom <$ unused 8 <*> get xGetAtomName display (Atom atom) = do putR display GetAtomName 0 2 $ putWord32 atom parseReply display $ do unused 8 n <- w16 unused 22 string8 (fi n) xChangeProperty display (Window wid) (Atom prop) (Atom ty) (F.PropertyMode mode) vs = do let (sz,l,bs) = case vs of F.Byte s -> (1,length s,putBytes (map c2w s)) F.Short ws -> (2,length ws,foldMap (putWord16.toEnum) ws) F.Long ls -> (4,length ls,foldMap (putWord32.toEnum) ls) n = toEnum (l*fi sz) p = pad n reqLen = 6+(n+p) `quot` 4 fmt = fi (8*sz) putR display ChangeProperty (toEnum mode) reqLen $ putWord32 wid<> putWord32 prop<> putWord32 ty<> putBytes [fmt,0,0,0]<> putWord32 (n `quot` sz)<> bs<> padding p xStoreName display w = xChangeProperty display w atom_WM_NAME atom_STRING F.propModeReplace . F.Byte xGrabButton display (Window wid) btn own eventmask = putR display GrabButton (b2w own) 6 $ putWord32 wid<> putPtrEventSet (bitset eventmask)<> putWord8x2 (1,1)<> -- pointer-mode async, keyboard-mode async putWord32 0<> -- confine-to none putWord32 0<> -- cursor none putWord8x2 (btn,0)<> putWord16 0x8000 -- AnyModifier xUngrabButton display (Window wid) btn = putR display UngrabButton btn 3 $ putWord32 wid<> putWord16 0x8000<> -- AnyModifier putWord16 0 xAllocColor display (Colormap cm) rgb@RGB{} = do putR display AllocColor 0 4 $ putWord32 cm<>put rgb<>padding 2 let color r = getFrom r $ do unused 8 rgb' <- get unused 2 px <- get return (Color px rgb rgb') either (const Nothing) (Just . color) <$> getReplyOrError display xAllocNamedColor display (Colormap cm) name = do let n = toEnum (length name) p = pad n reqLen = 3+(n+p) `quot` 4 putR display AllocNamedColor 0 reqLen $ putWord32 cm<> putWord16' n<> putWord16 0<> putStr8pad p name let color r = getFrom r $ unused 8 *> (Color <$> get <*> get <*> get) either (const Nothing) (Just . color) <$> getReplyOrError display instance FromX Pixel where get = Pixel <$> get instance FromX RGB where get = RGB <$> get <*> get <*> get xCreateGlyphCursor display (Font cf)(Font mf) glyph mask fg@F.RGB{} bg@F.RGB{} = do cid <- getNextId display putR display CreateGlyphCursor 0 8 $ putWord32 cid<> putWord32 cf<> putWord32 mf<> putWord16 (toEnum glyph)<> putWord16 (toEnum mask)<> put (fg,bg) return (Cursor cid) xGetKeyboardMapping display (KC start) count = do putR display GetKeyboardMapping 0 2 (put [start,toEnum count,0,0::Word8]) parseReply display $ do unused 1 n <- w8 _nm <- w32 unused 24 list (fi count) (list (fi n) (KS<$>w32be)) data Extension = Extension { present::Bool, majorOpCode,firstEvent,firstError::Word8 } deriving Show xQueryExtension display name = do let n = toEnum (length name) p = pad n len = 2+(n+p) `quot` 4 putR display QueryExtension 0 len $ putWord16' n<> putWord16 0<> putStr8pad p name parseReply display $ do unused 2 unused 2 -- sequence number unused 4 -- reply length Extension <$> get <*> get <*> get <*> get xListExtensions display = do putR display ListExtensions 0 1 nil parseReply display $ do unused 1 n <- fi <$> w8 unused 2 -- sequence number _len <- w32 -- reply length unused 24 -- unused replicateM n str xBell :: Display -> Int -> IO () xBell display n = putR display Bell (fi n) 1 nil xGetModifierMapping display = do putR display GetModifierMapping 0 1 nil parseReply display $ do unused 1 n <- fi<$>w8 unused 2 -- sequence nr unused 4 -- reply length unused 24 -- unused let ms = [F.Shift .. F.Mod5] zip ms <$> replicateM 8 (filter (/=0) <$> replicateM n w8) xNoOperation display n = putR display NoOperation 0 (1+n) $ padding (4*n) -------------------------------------------------------------------------------- -- https://www.x.org/releases/X11R7.7/doc/xextproto/shape.html xShapeCombineMask display (Window wid) kind xy (Pixmap pm) op | not (present shape) = return () -- | otherwise = putR' "ShapeCombineMask" display (majorOpCode shape) 2 5 $ put (op::F.ShapeOperation,kind::F.ShapeKind) <> putWord16 0 <> -- unused putWord32 wid <> putInt16x2 xy <> putWord32 pm where shape = shapeExt display instance Put F.ShapeOperation where put = putWord8 . convEnum instance Put F.ShapeKind where put = putWord8 . convEnum -- https://www.x.org/releases/X11R7.7/doc/xextproto/dbe.html#DBEGetVersion xdbeQueryExtension display | not (present dbe) = return (0,0,0) | otherwise = do putR' "DBEGetVersion" display (majorOpCode dbe) 0 2 $ putBytes [1,0,0,0] parseReply display $ do unused 8 major <- w8 minor <- w8 return (fromEnum 1,fromEnum major,fromEnum minor) where dbe = dbeExt display -- https://www.x.org/releases/X11R7.7/doc/xextproto/dbe.html#DBEAllocateBackBufferName xdbeAllocateBackBufferName display (Window wid) swap_action_hint | not (present dbe)=fail "xdbeAllocateBackBufferName: extension not present" | otherwise = do xid <- getNextId display putR' "DBEAllocateBackBufferName" display (majorOpCode dbe) 1 4 $ putWord32 wid<> putWord32 xid<> put (swap_action_hint::F.SwapAction)<> padding 3 return (DbeBackBufferId xid) where dbe = dbeExt display instance Put F.SwapAction where put = putWord8 . convEnum -- https://www.x.org/releases/X11R7.7/doc/xextproto/dbe.html#DBESwapBuffers xdbeSwapBuffers display (Window wid) swap_action | not (present dbe) = fail "xdbeSwapBuffers: extension not present" | otherwise = putR' "DBEAllocateBackBufferName" display (majorOpCode dbe) 3 len $ putWord32 n <> putWord32 wid<> put (swap_action::F.SwapAction)<> padding 3 where dbe = dbeExt display n = 1 len = 2+2*n -------------------------------------------------------------------------------- printResponseError r = do let errorNum = byte r 1 errorCode = safeToEnum E.UnknownError errorNum seqNr = word16 r 2 minor = word16 r 8 major = word16 r 10 rq = maybe "" show (request major) putStrLn $ "Response error ["++show errorNum++"] "++show errorCode++ "\tSeq: "++show seqNr++", Minor: "++show minor++ ", Major: "++show major++" "++rq -------------------------------------------------------------------------------- getReply display = either oops return =<< getReplyOrError display where oops r = do printResponseError r fail "Expected a reply, got an error" -- !! parseReply display g = runGet g <$> getReply display getReplyOrError display = do --debug "Get a reply" r <- dGet display 32 case byte r 0 of 0 -> return (Left r) 1 -> do let extra = word32 r 4 Right <$> if extra>0 then B.append r <$> dGet display (4*extra) else return r _ -> do --debug "Queueing an event" queueEvent display (decodeEvent r) getReplyOrError display queueEvent Display{eventQ=q} event = modifyIORef q (flip enter event) {- queueEvents d = do ready <- hReady (socket d) if not ready then return 0 else do r <- dGet d 32 case byte r 0 of 0 -> do printResponseError r fail "Noticed an error while trying to queue events" 1 -> fail "Got an unexpected reply while trying to queue events" _ -> do queueEvent d (decodeEvent r) succ <$> queueEvents d -} -- | Get the next event, no timeout xNextEvent display@Display{eventQ=qref} = maybe (getEvent display) return =<< dequeueEvent display -- | Wait for the next event or a timeout xWaitForEvent display timeout = either (const Nothing) Just <$> xSelect display [] [] (Just (1000*timeout)) -- | Wait for the next event, other input or a given timeout xSelect display rfds wfds timeout = maybe wait (return . Right) =<< dequeueEvent display where wait = do let s = s2fd (socket display) ready@(rds,_) <- select (s:rfds) wfds timeout if s `elem` rds then Right <$> getEvent display else return (Left ready) getEvent display = do r <- dGet display 32 case byte r 0 of 0 -> do printResponseError r error "Expected an event, got a response error" -- !! 1 -> error "Expected an event, got a reply" _ -> return (decodeEvent r) xEventsQueued display@Display{eventQ=qref} = not . Q.isempty <$> readIORef qref dequeueEvent display@Display{eventQ=qref} = do q <- readIORef qref case qremove q of Just (ev,q') -> do writeIORef qref q' return (Just ev) _ -> return Nothing -------------------------------------------------------------------------------- class Drawable d where drawable :: d -> XID instance Drawable Window where drawable (Window xid) = xid instance Drawable Pixmap where drawable (Pixmap xid) = xid instance Drawable DbeBackBufferId where drawable (DbeBackBufferId xid) = xid instance (Drawable a,Drawable b) => Drawable (Either a b) where drawable = either drawable drawable class Fontable f where fontable :: f -> XID instance Fontable Font where fontable (Font xid) = xid instance Fontable GC where fontable (GC xid) = xid -------------------------------------------------------------------------------- instance Put Line where put (L x1 y1 x2 y2) = put ((x1,y1),(x2,y2)) instance Put Rect where put (R x y w h) = put ((x,y),(w,h)) instance Put (BitSet a) where put (BitSet w) = putWord32 w instance Put F.RGB where put (F.RGB r g b) =foldMap (putWord16.toEnum) [r,g,b] instance Put VisualID where put (VisualID vid) = putWord32 (fi vid) instance Put Pixel where put (Pixel p) = put p instance Put RGB where put (RGB r g b) = put (r,g,b) putWord16' :: Word32 -> Putter putWord16' w | w<=65535 = putWord16 (fi w) putWord8x2 (a,b) = put2Word8 a b putInt16x2 (a,b) = putInt16 a<>putInt16 b --putWord32x2 (w1,w2) = putWord32 w1<>putWord32 w2 padding :: Word32 -> Putter padding p = putBytes $ replicate (fromEnum p) 0 putPtrEventSet :: BitSet EventMask -> Putter putPtrEventSet (BitSet w32) = putWord16 (convEnum w32) putStr8pad p s = put (map c2w s)<>padding (fi p) putStr16pad p s = foldMap c2w16be s<>padding p c2w16be :: Char -> Putter c2w16be = putWord16be . convEnum -------------------------------------------------------------------------------- class ValueMask a where valueMask :: a -> (Word32,Word32) valuesMask vs = mask . unzip . sortOn fst . nubBy ((==) `on`fst) $ map valueMask vs where mask (ms,vs) = ((foldl (.|.) 0 ms,vs),toEnum (length vs)) instance ValueMask (F.GCAttributes F.Pixel F.FontId) where valueMask a = case a of F.GCFunction f -> (0x000001,convEnum f) F.GCForeground (F.Pixel fg) -> (0x000004,convEnum fg) F.GCBackground (F.Pixel bg) -> (0x000008,convEnum bg) F.GCLineWidth lw -> (0x000010,convEnum lw) F.GCLineStyle ls -> (0x000020,convEnum ls) F.GCCapStyle cap -> (0x000040,convEnum cap) F.GCJoinStyle js -> (0x000080,convEnum js) F.GCFillStyle fs -> (0x000100,convEnum fs) F.GCTile pm -> (0x000400,pixmap pm) F.GCStipple pm -> (0x000800,pixmap pm) F.GCFont fid -> (0x004000,font fid) F.GCSubwindowMode m -> (0x008000,convEnum m) F.GCGraphicsExposures e -> (0x010000,convEnum e) F.GCArcMode m -> (0x400000,convEnum m) where pixmap (F.PixmapId (F.XID pm)) = toEnum pm font (F.FontId (F.XID fid)) = toEnum fid instance ValueMask F.WindowAttributes where valueMask a = case a of F.CWBackPixmap pm -> (0x0001,pixmap pm) F.CWBackPixel (F.Pixel bg) -> (0x0002,convEnum bg) F.CWBorderPixmap pm -> (0x0004,pixmap pm) F.CWBorderPixel (F.Pixel bg) -> (0x0008,convEnum bg) F.CWBitGravity gr -> (0x0010,convEnum gr) F.CWWinGravity gr -> (0x0020,convEnum gr) F.CWBackingStore yes -> (0x0040,convEnum yes) F.CWOverrideRedirect yes -> (0x0200,convEnum yes) F.CWSaveUnder yes -> (0x0400,convEnum yes) F.CWEventMask m -> (0x0800,bitWord (bitset m)) F.CWDontPropagate m -> (0x1000,bitWord (bitset m)) F.CWCursor (F.CursorId (F.XID cur)) -> (0x4000,toEnum cur) where pixmap (F.PixmapId (F.XID pm)) = toEnum pm instance ValueMask F.WindowChanges where valueMask change = case change of F.CWX x -> ( 1,fi x) F.CWY y -> ( 2,fi y) F.CWWidth w -> ( 4,toEnum w) F.CWHeight h -> ( 8,toEnum h) F.CWBorderWidth bw -> (0x10,toEnum bw) F.CWStackMode sm -> (0x40,convEnum sm)