{-# LANGUAGE CPP #-} module TagEvents(TRequest,TResponse,tagEventsSP,tagRequestsSP) where import Command import CompSP(preMapSP,serCompSP) import SpEither(mapFilterSP) import Cont(cmdContSP,getRightSP,conts) import CmdLineEnv(argFlag) --import Direction import Event --import Font(FontStruct) import Fudget import FRequest --import Geometry(Line, Point, Rect, Size(..)) import IOUtil(getEnvi) --import LayoutRequest(LayoutRequest) import Loopthrough import Message(stripLow) --Message(..), import Path import ShowCommandF import Sockets import Spops import Tables import Tables2 --import Version import Xtypes --import Maptrace --import EitherUtils import Data.Maybe(isNothing) import DialogueIO import Prelude hiding (IOError) --mtrace = ctrace "tagEvents" mtrace x y = y type TResponse = (Path,Response) type TRequest = (Path,Request) tagEventsSP :: F i o -> SP TResponse TRequest tagEventsSP mainF = loopThroughRightSP (openDisplay' tagEventsCtrlSP) (mapFilterSP stripLow `serCompSP` mainFSP `preMapSP` Low) where F mainFSP = traceit mainF openDisplay' cont = if isNothing (getEnvi "DISPLAY") then cont faildisp else cmdContSP (tox $ XRequest (noDisplay, noWindow, OpenDisplay "")) (\e -> case e of Right (_, XResponse (DisplayOpened d)) -> Just d Right (_, Failure f) -> error ("Cannot open the display (the program is probably not linked with the X routines): "++show f) _ -> Nothing) (\disp -> if disp == Display 0 then error "Cannot open display" else putSP (tox $ Select [DisplayDe disp]) $ cont disp) where faildisp = error "the environment variable DISPLAY is not set!" tox x = Right (here,x) tagEventsCtrlSP :: Display -> SP (Either TCommand TResponse) (Either TEvent TRequest) tagEventsCtrlSP disp = tagSP noSel Nothing wtable0 where noSel = here tagSP selp grabpath wtable = let same = tagSP selp grabpath wtable tagSPs = tagSP selp tagSPns s = tagSP s grabpath wtable in getSP $ \msg -> case msg of Left (path, cmd) -> let newwindow path' wid = putSP (Left (path', XResp (WindowCreated wid))) $ tagAdd path' wid tox xc = Right (path,xc) convertcmd = convert (lookupWid wtable path) convert w cmd = putSP (tox (XCommand (disp, w, cmd))) tagAdd p w = tagSPs grabpath (updateWtable wtable p w) in case cmd of XCmd xcmd@(SetSelectionOwner s atom) -> -- currently, different selections are not distinguished convertcmd xcmd $ (if s && selp /= noSel && path /= selp then putSP (Left (selp,XEvt (SelectionClear atom))) else id) $ tagSPns (if s then path else noSel) XCmd (ReparentToMe rchild w) -> -- lookup w in table, change path to rchild, emit reparent cmd -- TODO: change subpaths too! let npath' = newChildPath path rchild npath = autumnize npath' -- used in repTest (?) wpath = lookupPath wtable w opath = autumnize wpath nparent = lookupWid wtable path nwtable = moveWpaths wtable opath npath in convert w (ReparentWindow nparent) $ if null wpath then {-ctrace "rep" (npath',opath,w) $-} tagAdd npath' w else tagSPs grabpath nwtable XCmd (SelectWindow w) -> tagAdd path w XCmd GetWindowId-> putSP (Left (path,XEvt (YourWindowId wid))) same where wid = lookupWid wtable path XCmd DestroyWindow -> putsSP [tox (XCommand (disp, wid, DestroyWindow)) | wid <- subWids wtable path] $ tagSPs grabpath (pruneWid wtable path) XCmd (GrabEvents toMe) -> mtrace ("Grab",toMe,msg) $ tagSPs (Just (toMe,path,autumnize path)) wtable XCmd UngrabEvents -> tagSPs Nothing wtable --DoXCommands xcmds -> foldr convertcmd same xcmds XCmd (DrawMany w gcdcmdss) | not optimizeDrawMany -> foldr convertcmd same [Draw w gc dcmd | (gc,dcmds)<-gcdcmdss,dcmd<-dcmds] XCmd xcmd -> convertcmd xcmd same DReq req -> putSP (tox req) same SReq sreq -> putSP (tox (SocketRequest sreq)) same XReq xreq -> case xreq of CreateMyWindow _ -> error "GUI fudget outside a shell fudget" CreateSimpleWindow rchild _ -> createWindow disp xreq (lookupWid wtable path) (newwindow (newChildPath path rchild)) CreateRootWindow _ _ -> createWindow disp xreq rootWindow (newwindow path) _ -> putSP (tox (XRequest (disp, lookupWid wtable path, xreq))) same LCmd _ -> same -- layout pseudo command Right (path, resp) -> case resp of AsyncInput (_, XEvent (wid, event)) -> case event of MappingNotify -> same ButtonEvent {} -> checkGrab KeyEvent {} -> checkGrab MotionNotify {} -> checkGrab SelectionClear atom -> pass $ tagSPns noSel DestroyNotify w | destroyPrune -> pass $ tagSPs grabpath (pruneWtable wtable path2' w) _ -> passame where path2' = lookupPath wtable wid passto p = putSP (Left (p, XEvt event)) pass = passto path2' passame = pass same checkGrab = case grabpath of Nothing -> passame Just (toMe,kpath,path) -> if path `subPath` path2' then passame else if toMe then passto kpath same else same XResponse xresp -> putSP (Left (path,XResp xresp)) same SocketResponse sresp -> putSP (Left (path,SResp sresp)) same _ -> putSP (Left (path, DResp resp)) same destroyPrune = argFlag "destroyPrune" False newChildPath parent rchild = absPath (autumnize parent) rchild -------------------------------------------------------------------------------- createWindow disp xreq wid cont = cmdContSP (Right (here, XRequest (disp, wid, xreq))) (\msg -> case msg of Right (_, XResponse (WindowCreated wid')) -> Just wid' _ -> Nothing) cont tagRequestsSP :: SP TResponse TRequest -> SP Response Request tagRequestsSP = loopThroughRightSP (tagRequests dtable0) tagRequests dtable = getSP $ \msg -> case msg of Left (path, cmd) -> case cmd of Select ds -> let dtable' = updateDe path ds dtable in doReqSP (Select (listDe dtable')) $ \ resp -> checkErr resp $ tagRequests dtable' XCommand (d,w,DestroySockets) | null des -> tagRequests dtable -- handle common case faster | otherwise-> doReqSP (Select (listDe dtable')) $ \ resp -> checkErr resp $ conts (doReqSP . closeDe) des $ \ _ -> tagRequests dtable' where (des,dtable') = subDes dtable path XCommand _ -> putReqSP cmd $ -- \ resp -> -- The response to an XCommand is always Success -- and is not propagated to the originating fudget. tagRequests dtable _ -> doReqSP cmd $ \ resp -> putSP (Left (path, resp)) $ tagRequests dtable Right ai@(AsyncInput (d, i)) -> putSP (Left (lookupDe dtable d, ai)) $ tagRequests dtable _ -> error ("tagRequests: " ++ show msg ++ "\n") where checkErr resp cont = case resp of Success -> cont Failure ioerr -> error ("IOerror: " ++ show ioerr) doReqSP req = putReqSP req . getRespSP where getRespSP = getRightSP putReqSP = putSP . Right closeDe de = case de of LSocketDe s -> SocketRequest (CloseLSocket s) SocketDe s -> SocketRequest (CloseSocket s) BinSocketDe s -> SocketRequest (CloseSocket s) OutputSocketDe s -> SocketRequest (CloseSocket s) TimerDe t -> SocketRequest (DestroyTimer t) DisplayDe d -> XCommand (d,noWindow,CloseDisplay d) -- hmm traceit = showCommandF "debug" optimizeDrawMany = argFlag "optdrawmany" #if defined(__GLASGOW_HASKELL__) || defined(__PFE__) True #else False #warning "not optimising DrawMany" #endif