module XCall(doXCall,doSCall,getAsyncInput, XCallState,initXCall,otCatch,catchIo,rfail,ok) where import Control.Monad(unless) import Data.Word(Word8) import Data.Bits(bit) import Data.Char(isHexDigit,digitToInt,isLatin1) import Data.Maybe(mapMaybe) import Data.Ix import P_IO_data --(Request(..),Response(..)) import System.IO(hFlush,stdout,stderr,hPutStrLn) import System.IO.Error(catchIOError) import System.Posix.DynamicLinker as DL import System.Process(runInteractiveCommand) import SocketIO import qualified Data.ByteString.Char8 as C import Data.IORef import Command as F import Event as F import Xtypes as F import Sockets as F import Geometry as F import DrawTypes as F import X11 import X11Types as X11 import X11Event as X11 import X11Utils(fi) import XReadBitmap(xReadBitmapFileData) import Timers import IOUtil(lookupEnv) import HbcUtils(chopList,uncurry3,encodeUTF8) debug = hPutStrLn stderr data XCallState = XCallState X11.Display TimersVar (IORef [Descriptor]) (IORef Listening) Keymap type Listening = [(LSocket,NetSocket)] type Keymap = [[Keysym]] initXCall = do disp <- rootWindowHack =<< xOpenDefaultDisplay let kBounds@(kMin,kMax) = keycodeMinMax disp count = rangeSize kBounds XCallState disp <$> initTimers <*> newIORef [] <*> newIORef [] <*> (strict <$> xGetKeyboardMapping disp kMin count) where strict km = seq (km==km) km --unevaluated keymap entries use a lot of memory rootWindowHack disp = maybe disp hack <$> lookupEnv "FUD_rootwindow" where hack w = disp{screens=[(screen disp){rootWindowId=Window (read w)}]} stdioXCall :: Request -> IO Response stdioXCall req = do --hPrint stderr req print req hFlush stdout s <- getLine resp <- readIO s `catchIOError` \ _ -> fail $ "Read failed on "++show s --hPrint stderr resp return resp doSCall = doXCall doXCall iostate@(XCallState disp tref dsref _lis km) req = --print req >> case req of XRequest r -> otCatch (XResponse <$> doXRequest iostate r) XCommand c -> otCatch (Success <$ doXCommand iostate c) GetAsyncInput -> getAsyncInput iostate SocketRequest r -> otCatch $ doSocketRequest iostate r Select dl -> do --print req Success <$ writeIORef dsref dl _ -> fail $ "Not implemented yet: "++show req otCatch io = catchIo OtherError io catchIo e io = catchIOError io (rfail . e . show) ok :: IO Response ok = return Success rfail = return . Failure -------------------------------------------------------------------------------- getAsyncInput iostate = otCatch (AsyncInput <$> getAsyncInput' iostate) getAsyncInput' iostate@(XCallState disp tref dsref lis km) = do ss <- mapMaybe socketFd <$> readIORef dsref t <- fmap (1000*) <$> timeLeft tref either (other ss) event =<< xSelect disp (map fst ss) [] t where socketFd d = case d of SocketDe so -> Just (s2fd so,d) BinSocketDe so -> Just (s2fd so,d) LSocketDe so -> Just (ls2fd so,d) _ -> Nothing other ss (rs,_) = --debug $ "Ready: "++show rs case rs of [] -> timeout rfd:_ -> case lookup rfd ss of Just sd@(SocketDe so) -> do bs <- sRead so 2000 return (sd,SocketRead (C.unpack bs)) Just sd@(BinSocketDe so) -> do bs <- sRead so 2000 return (sd,SocketReadBin bs) Just sd@(LSocketDe ls) -> do Just nls <- lookup ls <$> readIORef lis (so,host,pn) <- accept nls return (sd,SocketAccepted so host) --} timeout = do tno <- removeTimeQ tref return (TimerDe tno,TimerAlarm) event ev = case ev of OtherEvent{} -> ignored X11.MappingNotify{} -> ignored _ -> return (DisplayDe theDisplay,XEvent (xhbEvent disp km ev)) where ignored = do debug $ "Ignored "++show ev -- !! getAsyncInput' iostate -------------------------------------------------------------------------------- doSocketRequest iostate@(XCallState disp tref _dsref lis km) soReq = case soReq of CreateTimer interval first -> sr . Timer <$> createTimer tref interval first DestroyTimer t -> Success <$ destroyTimer tref t OpenLSocket port-> do nls <- listenOn (pn port) let ls = nls2ls nls modifyIORef lis ((ls,nls):) returnS $ LSocket ls OpenSocket host port -> sr . Socket <$> connectTo host (pn port) CloseSocket so -> Success <$ closeS so CloseLSocket so -> do ls <- readIORef lis let ls' = [(ls,nls)|(ls,nls)<-ls,ls/=so] writeIORef lis ls' Success <$ closeLs so WriteSocket so str -> Success <$ sWrite so (C.pack str) DLOpen path -> do dh <- dlopen path [RTLD_LAZY] case dh of Null -> Failure . OtherError <$> dlerror _ -> returnS $ F.DLHandle (F.DL dh) DLClose (DL dh) -> Success <$ dlclose dh {- DLSym (DL dh) name -> do FunPtr fp <- dlsym dh name case addrToAny# fp of (# hval #) -> returnS . DLVal $ DLValue (unsafeCoerce hval) -} StartProcess cmd True True True -> do (h0,h1,h2,_) <- runInteractiveCommand cmd [stdin,stdout,stderr] <- mapM h2s [h0,h1,h2] returnS $ ProcessSockets (Just stdin) (Just stdout) (Just stderr) _ -> fail $ "Socket request not implemented yet: "++show soReq where pn = PortNumber . fi returnS = return . sr sr = SocketResponse -------------------------------------------------------------------------------- theDisplay = Display 1 doXRequest iostate@(XCallState disp tref _dsref _lis km) (_disp,wid,xreq) = --xNoOperation disp 500 >> -- debugging case xreq of OpenDisplay dn | dn `elem` ["",displayName disp] -> return (DisplayOpened theDisplay) | otherwise -> fail "Can only open the default display" CreateRootWindow rect rsrc -> WindowCreated . xhb <$> xCreateWindow' disp (rootWindowId (screen disp)) (xhb rect) bw [] CreateSimpleWindow _path rect -> WindowCreated . xhb <$> xCreateWindow' disp (xhb wid) (xhb rect) bw wa where wa = [CWBorderPixel (xhb (blackPixel s)), CWBackPixel (xhb (whitePixel s))] s = screen disp AllocColor cm rgb -> ColorAllocated . fmap xhb <$> xAllocColor disp (cmap cm) (xhb rgb) AllocNamedColor cm ('#':s) | length s `elem` [3,6] && all isHexDigit s -> ColorAllocated . fmap xhb <$>xAllocColor disp (cmap cm) (xhb (hexColor s)) AllocNamedColor cm c -> ColorAllocated . fmap xhb <$> xAllocNamedColor disp (cmap cm) c ListFontsWithInfo fn n->GotFontListWithInfo <$> xListFontsWithInfo disp fn (toEnum n) InternAtom name b -> GotAtom . xhb <$> xInternAtom disp name b GetAtomName atom -> GotAtomName . Just <$> xGetAtomName disp (xhb atom) LoadFont fontname -> FontLoaded . xhb <$> xLoadFont disp fontname QueryFont font -> FontQueried . Just <$> xQueryFont disp (xhb font) LoadQueryFont fontname -> FontQueried . Just <$> (xQueryFont disp =<< xLoadFont disp fontname) QueryTextExtents16 font s -> do ((fa,fd),overall) <- xQueryTextExtents16 disp (xhb font) s return (TextExtents16Queried fa fd overall) CreateGC dr (GCId 0) vs -> GCCreated . xhb <$> xCreateGC' disp (drawable dr) (vs++vs0) where vs0 = [GCForeground (xhb (blackPixel s)), GCBackground (xhb (whitePixel s))] s = screen disp --} CreateGC dr oldgc vs -> do newgc <- xCreateGC' disp (drawable dr) [] xCopyGC disp (xhb oldgc) newgc xChangeGC disp newgc vs return $ GCCreated $ xhb newgc CreateFontCursor cur -> do fid <- xLoadFont disp "cursor" -- !! CursorCreated .xhb <$> xCreateGlyphCursor disp fid fid cur (cur+1) blackRGB whiteRGB CreatePixmap (Point w h) depth -> do let depth' = if depth == copyFromParent then rootDepth (screen disp) else toEnum depth sz = (toEnum w,toEnum h) PixmapCreated . xhb <$> xCreatePixmap disp mywindow sz depth' CreateBitmapFromData bmdata -> createBitmapFromData bmdata DefaultVisual -> return $ GotVisual (defaultVisual disp) DbeQueryExtension ->uncurry3 DbeExtensionQueried <$> xdbeQueryExtension disp DbeAllocateBackBufferName swapAction -> DbeBackBufferNameAllocated . xhb <$> xdbeAllocateBackBufferName disp (xhb wid) swapAction DbeSwapBuffers swapAction -> DbeBuffersSwapped 1 <$ xdbeSwapBuffers disp (xhb wid) swapAction ReadBitmapFile path -> do Just (_name,(Just (w,h),hot,bits)) <- xReadBitmapFileData path let hot' = uncurry pP <$> hot createBitmapFromData (Bitmap (Point w h) hot' bits) _ -> fail $ "X request not implemented yet: "++show xreq where bw = toEnum border_width mywindow = someWindow wid drawable MyWindow = Left mywindow drawable (F.Pixmap pm) = Right (xhb pm) cmap cm | cm==F.defaultColormap = X11.defaultColormap (screen disp) | otherwise = xhb cm someWindow wid | wid==noWindow = rootWindowId (screen disp) | otherwise = xhb wid padScanlines _ 0 = id padScanlines w pad = concatMap (++zs) . chopList (splitAt w) where zs = replicate pad 0 createBitmapFromData (Bitmap size@(Point w h) hot bs0) = do let sz = (toEnum w,toEnum h) wi' = someWindow wid padTo = bitmapPad disp `quot` 8 bpl = (w+7) `quot` 8 -- bytes per scanline in bitmap data pad = (padTo - bpl `rem` padTo) `rem` padTo bs = padScanlines bpl pad (map toEnum bs0) --print (w,bpl,padTo,pad) pm <- xCreatePixmap disp wi' sz 1 gc <- xCreateGC' disp pm [GCBackground pixel0,GCForeground pixel1] xPutImage disp pm gc 1 sz (0,0) xyBitmap (bs::[Word8]) xFreeGC disp gc -- hmm return $ BitmapRead (BitmapReturn (Bitmap size hot (xhb pm))) -------------------------------------------------------------------------------- doXCommand iostate@(XCallState disp tref _dsref _lis km) (_disp,wid,xcmd) = --xNoOperation disp 500 >> -- debugging case xcmd of ChangeWindowAttributes as -> xChangeWindowAttributes disp (xhb wid) as DestroyWindow -> xDestroyWindow disp (xhb wid) ConfigureWindow cs -> xConfigureWindow disp (xhb wid) cs ClearWindow -> xClearArea disp (xhb wid) (R 0 0 0 0) False ClearArea r e -> xClearArea disp (xhb wid) (xhb r) e StoreName name -> do xStoreName disp (xhb wid) (filter isLatin1 name) -- !! net_wm_name <- xInternAtom disp "_NET_WM_NAME" True utf8 <- xInternAtom disp "UTF8_STRING" True let vs = Byte (encodeUTF8 name) xChangeProperty disp (xhb wid) net_wm_name utf8 propModeReplace vs SetNormalHints (Point x y) -> xChangeProperty disp (xhb wid) prop ty propModeReplace vs where prop = xhb atom_WM_NORMAL_HINTS ty = xhb atom_WM_SIZE_HINTS vs = Long [1,x,y,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] SetWMHints inputHint -> xChangeProperty disp (xhb wid) atom atom propModeReplace vs where atom = xhb atom_WM_HINTS vs = Long [1,fromEnum inputHint,0,0,0,0,0,0,0] SetWMProtocols as -> do prop <- xInternAtom disp "WM_PROTOCOLS" True let vs = Long [a|F.Atom a<-as] xChangeProperty disp (xhb wid) prop X11.atom_ATOM propModeReplace vs ChangeProperty w p t fmt@8 mode s -> xChangeProperty disp (xhb w) (xhb p) (xhb t) mode (Byte s) MapRaised -> do xConfigureWindow disp (xhb wid) [CWStackMode StackAbove] xMapWindow disp (xhb wid) UnmapWindow -> xUnmapWindow disp (xhb wid) GrabButton oe button ms evm-> xGrabButton disp (xhb wid) (xhb button) oe evm UngrabButton button ms -> xUngrabButton disp (xhb wid) (xhb button) FreeGC gc -> xFreeGC disp (xhb gc) FreePixmap pm -> xFreePixmap disp (xhb pm) Draw dr gc dcmd -> draw (drawable dr) (xhb gc) dcmd DrawMany dr ds -> mapM_ drawCmds ds where drawCmds (gc,dcmds) = mapM_ (draw dr' (xhb gc)) dcmds dr' = drawable dr Bell n -> xBell disp (toEnum n) ShapeCombineMask kind p pm op -> xShapeCombineMask disp (xhb wid) kind (xhb p) (xhb pm) op Flush -> xFlush disp _ -> debug $ "X command not implemented yet: "++show xcmd where draw dr gc dcmd = -- putStr "*** " >> print dcmd >> getLine >> case dcmd of DrawString p s -> drawStr16 dr gc p s -- !! DrawString16 p s -> drawStr16 dr gc p s DrawImageString p s -> drawImgStr dr gc p (latin1 s) DrawImageString16 p s -> drawImgStr16 dr gc p s DrawPoint p -> xDrawPoints disp dr gc [xhb p] DrawLine l -> xDrawLine disp dr gc (xhb l) DrawLines (Points cm ps) -> xDrawLines disp dr gc (map xhb ps) cm DrawArc r a1 a2 -> xDrawArc disp dr gc (xhb r) (toEnum a1) (toEnum a2) FillArc r a1 a2 -> xFillArc disp dr gc (xhb r) (toEnum a1) (toEnum a2) FillPolygon sh (Points m ps)-> xFillPolygon disp dr gc (map xhb ps) sh m DrawRectangle r -> xDrawRectangle disp dr gc (xhb r) FillRectangle r -> xFillRectangle disp dr gc (xhb r) CopyPlane from src dst plane -> xCopyPlane disp (drawable from) dr gc (xhb src) (xhb dst) (bit plane) CopyArea from src dst -> xCopyArea disp (drawable from) dr gc (xhb src) (xhb dst) CreatePutImage rect fmt pixels | fmt==zPixmap-> -- Check that bpp==32 in the pixmap format for depth d !! xPutImage disp dr gc d (w,h) (x,y) fmt (map xhb pixels) where d = rootDepth (screen disp) R x y w h = xhb rect _ -> debug $ "Draw command not implemented yet: "++show dcmd drawable MyWindow = Left (xhb wid) drawable (F.Pixmap pm) = Right (Left (xhb pm)) drawable (DbeBackBuffer bbid) = Right (Right (xhb bbid)) -- l s = length s<255 latin1 = map l1 l1 c = if isLatin1 c then c else '\0' -- hmm drawStr16 = drawStr' . xDrawString16 disp drawImgStr = drawStr' . xDrawImageString disp drawImgStr16 = drawStr' . xDrawImageString16 disp drawStr' xDrawStr gc p s = case splitAt 254 s of (s1,s2) -> do xDrawStr gc (xhb p) s1 unless (null s2) $ do (_,ext) <- xQueryTextExtents16 disp gc s drawStr' xDrawStr gc (move p (pP (char_width ext) 0)) s2 -------------------------------------------------------------------------------- class XHB a b | a->b where xhb :: a->b instance XHB F.Rect X11.Rect where xhb (F.Rect r (F.Point w h)) = X11.R x y (toEnum w) (toEnum h) where (x,y) = xhb r instance XHB F.Line X11.Line where xhb (F.Line p1 p2) = X11.L x1 y1 x2 y2 where (x1,y1) = xhb p1 (x2,y2) = xhb p2 instance XHB X11.Rect F.Rect where xhb (X11.R x y w h) = F.Rect (xhb (x,y)) (F.Point (fromEnum w) (fromEnum h)) instance XHB F.Point X11.Point where xhb (F.Point x y) = (toEnum x,toEnum y) instance XHB X11.Point F.Point where xhb (x,y) = F.Point(fromEnum x)(fromEnum y) instance XHB X11.Window F.Window where xhb (X11.Window xid) = F.WindowId (xhb xid) instance XHB F.Window X11.Window where xhb (F.WindowId xid) = X11.Window (xhb xid) instance XHB X11.XID F.XID where xhb xid = F.XID (fromEnum xid) instance XHB F.XID X11.XID where xhb (F.XID xid) = toEnum xid instance XHB Font FontId where xhb (Font xid) = FontId (xhb xid) instance XHB FontId Font where xhb (FontId xid) = Font (xhb xid) instance XHB X11.Atom F.Atom where xhb (X11.Atom a) = F.Atom (fromEnum a) instance XHB F.Atom X11.Atom where xhb (F.Atom a) = X11.Atom (toEnum a) instance XHB GCId GC where xhb (GCId xid) = GC (toEnum xid) instance XHB GC GCId where xhb (GC xid) = GCId (fromEnum xid) instance XHB Cursor CursorId where xhb (Cursor cid) = CursorId (xhb cid) instance XHB Pixmap PixmapId where xhb (X11.Pixmap cid) = PixmapId (xhb cid) instance XHB PixmapId Pixmap where xhb (PixmapId cid) = X11.Pixmap (xhb cid) instance XHB Keycode KeyCode where xhb (KC k) = KeyCode (fromEnum k) instance XHB F.DbeBackBufferId X11.DbeBackBufferId where xhb (F.DbeBackBufferId xid) = X11.DbeBackBufferId (xhb xid) instance XHB X11.DbeBackBufferId F.DbeBackBufferId where xhb (X11.DbeBackBufferId xid) = F.DbeBackBufferId (xhb xid) instance XHB ColormapId Colormap where xhb (ColormapId cm) = X11.Colormap (xhb cm) instance XHB F.Pixel X11.Pixel where xhb (F.Pixel p) = X11.Pixel (toEnum (fromEnum p)) instance XHB X11.Pixel F.Pixel where xhb (X11.Pixel p) = F.Pixel (toEnum (fromEnum p)) instance XHB X11.Color F.Color where xhb (X11.Color px rgb _) = F.Color (xhb px) (xhb rgb) instance XHB X11.RGB F.RGB where xhb (X11.RGB r g b)=F.RGB (fi r) (fi g) (fi b) instance XHB F.RGB X11.RGB where xhb (F.RGB r g b)=X11.RGB (fi r) (fi g) (fi b) instance XHB F.Button Word8 where -- hmm xhb AnyButton = 0 xhb (F.Button b) = toEnum b instance XHB X11.Pressed F.Pressed where xhb X11.Pressed = F.Pressed xhb X11.Released = F.Released xhbEvent disp km ev = case ev of X11.Expose ser w area count -> (xhb w,F.Expose (xhb area) (fromEnum count)) NoExposure ser w -> (xhb w,NoExpose) X11.Input ser (Key pressed kc) t rw w rp ep ms -> (xhb w,F.KeyEvent (fromEnum t) (xhb ep) (xhb rp) ms (xhb pressed) (xhb kc) ks s) where ix = fromEnum (Shift `elem` ms) -- !! kss = km !! index kBounds kc ks0 = kss !! ix ks1 = if ks0 == noSymbol then kss !! 0 else ks0 (ks,s) = lookupKeysym ks1 X11.Input ser (X11.Button pressed b) t rw w rp ep ms -> (xhb w,F.ButtonEvent (fromEnum t) (xhb ep) (xhb rp) ms (xhb pressed) (F.Button (fromEnum b))) X11.Input ser (X11.Motion hint) t rw ew rp ep ms -> (xhb ew,F.MotionNotify (fromEnum t) (xhb ep) (xhb rp) ms) X11.ReparentNotify ser ew w pa xy ov -> (xhb ew,F.ReparentNotify) X11.ConfigureNotify ser ew wi area bw ov -> (xhb ew,F.ConfigureNotify (xhb area) (fromEnum bw)) X11.CreateNotify ser ew wi area bw ov -> (xhb ew,F.CreateNotify (xhb wi)) X11.DestroyNotify ser ew wi -> (xhb ew,F.DestroyNotify (xhb wi)) X11.MapNotify ser ew wi ov -> (xhb ew,F.MapNotify (xhb wi)) X11.UnmapNotify ser ew wi ov -> (xhb ew,F.UnmapNotify (xhb wi)) X11.PointerWindow ser X11.Enter det mode t rw ew rp ep fo -> (xhb ew,F.EnterNotify (fromEnum t) (xhb ep) (xhb rp) det mode fo) X11.PointerWindow ser X11.Leave det mode t rw ew rp ep fo -> (xhb ew,F.LeaveNotify (fromEnum t) (xhb ep) (xhb rp) det mode fo) X11.Focus ser X11.In detail mode ew -> (xhb ew,F.FocusIn detail mode) X11.Focus ser X11.Out detail mode ew -> (xhb ew,F.FocusOut detail mode) X11.ClientMessage ser ew ty vs -> (xhb ew,F.ClientMessage (xhb ty) vs) _ -> error $ "Event not implemented: :"++show ev where kBounds = keycodeMinMax disp hexColor [r,g,b] = F.RGB (f r) (f g) (f b) where f i = 0x1111*digitToInt i hexColor [r1,r2,g1,g2,b1,b2] = F.RGB (f r1 r2) (f g1 g2) (f b1 g2) where f i1 i2 = 0x0101*(0x10*digitToInt i1+digitToInt i2)