{-# LANGUAGE CPP #-}
module TagEvents(tagEventsSP) where
import Command
import CompSP(preMapSP,serCompSP)
import SpEither(mapFilterSP)
import Cont(cmdContSP)
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 WindowF(autumnize)
import ShowCommandF
import Sockets
import Spops
import Tables
--import Version
import Xtypes
--import Maptrace
--import EitherUtils
import Data.Maybe(isNothing)
import ShowFailure
import DialogueIO
import Prelude hiding (IOError)

--mtrace = ctrace "tagEvents"
mtrace :: p -> p -> p
mtrace p
x p
y = p
y

tagEventsSP :: F i o -> SP (Path, Response) (Path, Request)
tagEventsSP :: F i o -> SP (Path, Response) (Path, Request)
tagEventsSP F i o
mainF =
    SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP TEvent TCommand -> SP (Path, Response) (Path, Request)
forall a1 a2 a3 b.
SP (Either a1 a2) (Either a3 b) -> SP a3 a1 -> SP a2 b
loopThroughRightSP
      SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagEventsCtrlSP
      ((Message TCommand o -> Maybe TCommand)
-> SP (Message TCommand o) TCommand
forall t b. (t -> Maybe b) -> SP t b
mapFilterSP Message TCommand o -> Maybe TCommand
forall a b. Message a b -> Maybe a
stripLow SP (Message TCommand o) TCommand
-> SP (FEvent i) (Message TCommand o) -> SP (FEvent i) TCommand
forall a1 b a2. SP a1 b -> SP a2 a1 -> SP a2 b
`serCompSP` SP (FEvent i) (Message TCommand o)
mainFSP SP (FEvent i) TCommand
-> (TEvent -> FEvent i) -> SP TEvent TCommand
forall a b t. SP a b -> (t -> a) -> SP t b
`preMapSP` TEvent -> FEvent i
forall a b. a -> Message a b
Low)
  where
    F SP (FEvent i) (Message TCommand o)
mainFSP = F i o -> F i o
forall a b. F a b -> F a b
traceit F i o
mainF

openDisplay' :: (Display -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
openDisplay' Display -> SP (Either a (a, Response)) (Either a (Path, Request))
cont =
    if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (String -> Maybe String
getEnvi String
"DISPLAY")
    then Display -> SP (Either a (a, Response)) (Either a (Path, Request))
cont Display
forall a. a
faildisp
    else
    Either a (Path, Request)
-> (Either a (a, Response) -> Maybe Display)
-> (Display
    -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
forall a b c. a -> (b -> Maybe c) -> Cont (SP b a) c
cmdContSP (Request -> Either a (Path, Request)
forall b a. b -> Either a (Path, b)
tox (Request -> Either a (Path, Request))
-> Request -> Either a (Path, Request)
forall a b. (a -> b) -> a -> b
$ (Display, XWId, XRequest) -> Request
XRequest (Display
noDisplay, XWId
noWindow, String -> XRequest
OpenDisplay String
""))
              (\Either a (a, Response)
e ->
               case Either a (a, Response)
e of
                 Right (a
_, XResponse (DisplayOpened Display
d)) -> Display -> Maybe Display
forall a. a -> Maybe a
Just Display
d
                 Right (a
_, Failure IOError
f) -> String -> Maybe Display
forall a. HasCallStack => String -> a
error (String
"Cannot open the display (the program is probably not linked with the X routines): "String -> String -> String
forall a. [a] -> [a] -> [a]
++IOError -> String
showFailure IOError
f)
                 Either a (a, Response)
_ -> Maybe Display
forall a. Maybe a
Nothing)
              (\Display
disp ->
               if Display
disp Display -> Display -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Display
Display Int
0 then
                   String -> SP (Either a (a, Response)) (Either a (Path, Request))
forall a. HasCallStack => String -> a
error String
"Cannot open display"
               else
                   Either a (Path, Request)
-> SP (Either a (a, Response)) (Either a (Path, Request))
-> SP (Either a (a, Response)) (Either a (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (Request -> Either a (Path, Request)
forall b a. b -> Either a (Path, b)
tox (Request -> Either a (Path, Request))
-> Request -> Either a (Path, Request)
forall a b. (a -> b) -> a -> b
$ [Descriptor] -> Request
Select [Display -> Descriptor
DisplayDe Display
disp]) (SP (Either a (a, Response)) (Either a (Path, Request))
 -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
-> SP (Either a (a, Response)) (Either a (Path, Request))
forall a b. (a -> b) -> a -> b
$ Display -> SP (Either a (a, Response)) (Either a (Path, Request))
cont Display
disp)
  where faildisp :: a
faildisp = String -> a
forall a. HasCallStack => String -> a
error String
"the environment variable DISPLAY is not set!"
        tox :: b -> Either a (Path, b)
tox b
x = (Path, b) -> Either a (Path, b)
forall a b. b -> Either a b
Right (Path
here,b
x)

tagEventsCtrlSP::
    SP (Either TCommand (Path,Response)) (Either TEvent (Path,Request))
tagEventsCtrlSP :: SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagEventsCtrlSP =
    (Display
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a a.
(Display -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
openDisplay' Display
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagEventsCtrlSP'
  where
    tagEventsCtrlSP' :: Display
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagEventsCtrlSP' Display
disp =
	Path
-> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSP Path
noSel Maybe (Bool, Path, Path)
forall a. Maybe a
Nothing PathTree XWId
forall n. PathTree n
path2wid0 Table (XWId, Path)
forall a. Table a
wid2path0
      where
	noSel :: Path
noSel = Path
here
	tagSP :: Path
-> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSP Path
selp Maybe (Bool, Path, Path)
grabpath PathTree XWId
path2wid Table (XWId, Path)
wid2path =
	  let same :: SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same = Path
-> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSP Path
selp Maybe (Bool, Path, Path)
grabpath PathTree XWId
path2wid Table (XWId, Path)
wid2path
	      tagSPs :: Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs = Path
-> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSP Path
selp
	      tagSPns :: Path
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPns Path
s = Path
-> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSP Path
s Maybe (Bool, Path, Path)
grabpath PathTree XWId
path2wid Table (XWId, Path)
wid2path
	  in Cont
  (SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
  (Either TCommand (Path, Response))
forall a b. Cont (SP a b) a
getSP Cont
  (SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
  (Either TCommand (Path, Response))
-> Cont
     (SP
        (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
     (Either TCommand (Path, Response))
forall a b. (a -> b) -> a -> b
$ \Either TCommand (Path, Response)
msg -> case Either TCommand (Path, Response)
msg of
	    Left (Path
path', FRequest
cmd) ->
	      let newwindow :: Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
newwindow Path
path'' XWId
wid = 
		    Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
path'', XResponse -> FResponse
XResp (XWId -> XResponse
WindowCreated XWId
wid))) (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$
		    Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagAdd Path
path'' XWId
wid
		  tox :: b -> Either a (Path, b)
tox b
xc = (Path, b) -> Either a (Path, b)
forall a b. b -> Either a b
Right (Path
path',b
xc)
		  convertcmd :: XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convertcmd = XWId
-> XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
forall a a.
XWId
-> XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convert (PathTree XWId -> Path -> XWId
lookupWid PathTree XWId
path2wid Path
path')
		  convert :: XWId
-> XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convert XWId
w XCommand
cmd = Either a (Path, Request)
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (Request -> Either a (Path, Request)
forall b a. b -> Either a (Path, b)
tox ((Display, XWId, XCommand) -> Request
XCommand (Display
disp, XWId
w, XCommand
cmd)))
		  tagAdd :: Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagAdd Path
p XWId
w = Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs Maybe (Bool, Path, Path)
grabpath (PathTree XWId -> Path -> XWId -> PathTree XWId
updateWid PathTree XWId
path2wid Path
p XWId
w) 
					       (Table (XWId, Path) -> XWId -> Path -> Table (XWId, Path)
forall a b. Ord a => Table (a, b) -> a -> b -> Table (a, b)
updatePath Table (XWId, Path)
wid2path XWId
w Path
p)
	      in case FRequest
cmd of
		 XCmd xcmd :: XCommand
xcmd@(SetSelectionOwner Bool
s Atom
atom) ->
		 -- currently, different selections are not distinguished
		   XCommand
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a.
XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convertcmd XCommand
xcmd (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$ 
		   (if Bool
s Bool -> Bool -> Bool
&& Path
selp Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
noSel Bool -> Bool -> Bool
&& Path
path' Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
selp then 
		       Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
selp,XEvent -> FResponse
XEvt (Atom -> XEvent
SelectionClear Atom
atom))) else SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a. a -> a
id) (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$
		   Path
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPns (if Bool
s then Path
path' else Path
noSel)
		 XCmd (ReparentToMe Path
rchild XWId
w) -> 
		   -- lookup w in table, change path to rchild, emit reparent cmd
		   -- TODO: change subpaths too!
		   let npath' :: Path
npath' = Path -> Path -> Path
newChildPath Path
path' Path
rchild
		       npath :: Path
npath = Path -> Path
forall a. [a] -> [a]
autumnize Path
npath' -- used in repTest (?)
		       wpath :: Path
wpath = Table (XWId, Path) -> XWId -> Path
forall a. Ord a => Table (a, Path) -> a -> Path
lookupPath Table (XWId, Path)
wid2path XWId
w
		       opath :: Path
opath = Path -> Path
forall a. [a] -> [a]
autumnize Path
wpath
		       nparent :: XWId
nparent = PathTree XWId -> Path -> XWId
lookupWid PathTree XWId
path2wid Path
path'
		       npath2wid :: PathTree XWId
npath2wid = PathTree XWId -> Path -> Path -> PathTree XWId
moveWids PathTree XWId
path2wid Path
opath Path
npath
		       nwid2path :: Table (XWId, Path)
nwid2path = Table (XWId, Path) -> Path -> Path -> Table (XWId, Path)
forall a. Table (a, Path) -> Path -> Path -> Table (a, Path)
movePaths Table (XWId, Path)
wid2path Path
opath Path
npath
		   in XWId
-> XCommand
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a.
XWId
-> XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convert XWId
w (XWId -> XCommand
ReparentWindow XWId
nparent) (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$
		      if Path -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Path
wpath
		      then {-ctrace "rep" (npath',opath,w) $-} Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagAdd Path
npath' XWId
w
		      else Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs Maybe (Bool, Path, Path)
grabpath PathTree XWId
npath2wid Table (XWId, Path)
nwid2path
		 XCmd (SelectWindow XWId
w) -> Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagAdd Path
path' XWId
w
		 XCmd XCommand
GetWindowId -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
path',XEvent -> FResponse
XEvt (XWId -> XEvent
YourWindowId XWId
wid))) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		     where wid :: XWId
wid = PathTree XWId -> Path -> XWId
lookupWid PathTree XWId
path2wid Path
path'
		 XCmd XCommand
DestroyWindow ->
		   [Either TEvent (Path, Request)]
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. [b] -> SP a b -> SP a b
putsSP [Request -> Either TEvent (Path, Request)
forall b a. b -> Either a (Path, b)
tox ((Display, XWId, XCommand) -> Request
XCommand (Display
disp, XWId
wid, XCommand
DestroyWindow))
			  | XWId
wid <- PathTree XWId -> Path -> [XWId]
subWids PathTree XWId
path2wid Path
path']
			 (Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs Maybe (Bool, Path, Path)
grabpath (PathTree XWId -> Path -> PathTree XWId
pruneWid PathTree XWId
path2wid Path
path') Table (XWId, Path)
wid2path)
		 XCmd (GrabEvents Bool
toMe) -> (String, Bool, Either TCommand (Path, Response))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall p p. p -> p -> p
mtrace (String
"Grab",Bool
toMe,Either TCommand (Path, Response)
msg) (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$
		   Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs ((Bool, Path, Path) -> Maybe (Bool, Path, Path)
forall a. a -> Maybe a
Just (Bool
toMe,Path
path',Path -> Path
forall a. [a] -> [a]
autumnize Path
path')) PathTree XWId
path2wid Table (XWId, Path)
wid2path
		 XCmd XCommand
UngrabEvents -> Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs Maybe (Bool, Path, Path)
forall a. Maybe a
Nothing PathTree XWId
path2wid Table (XWId, Path)
wid2path
		 --DoXCommands xcmds -> foldr convertcmd same xcmds
		 XCmd (DrawMany Drawable
w [(GCId, [DrawCommand])]
gcdcmdss) | Bool -> Bool
not Bool
optimizeDrawMany ->
		    (XCommand
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> [XCommand]
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr XCommand
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a.
XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convertcmd SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		      [Drawable -> GCId -> DrawCommand -> XCommand
Draw Drawable
w GCId
gc DrawCommand
dcmd | (GCId
gc,[DrawCommand]
dcmds)<-[(GCId, [DrawCommand])]
gcdcmdss,DrawCommand
dcmd<-[DrawCommand]
dcmds]
		 XCmd XCommand
xcmd -> XCommand
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a.
XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convertcmd XCommand
xcmd SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		 DReq Request
req -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (Request -> Either TEvent (Path, Request)
forall b a. b -> Either a (Path, b)
tox Request
req) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		 SReq SocketRequest
sreq -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (Request -> Either TEvent (Path, Request)
forall b a. b -> Either a (Path, b)
tox (SocketRequest -> Request
SocketRequest SocketRequest
sreq)) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		 XReq XRequest
xreq ->
		   case XRequest
xreq of
		     CreateMyWindow Rect
_ -> String
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a. HasCallStack => String -> a
error String
"GUI fudget outside a shell fudget"
		     CreateSimpleWindow Path
rchild Rect
_ ->
			Display
-> XRequest
-> XWId
-> (XWId
    -> SP
         (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a a.
Display
-> XRequest
-> XWId
-> (XWId -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
createWindow Display
disp XRequest
xreq (PathTree XWId -> Path -> XWId
lookupWid PathTree XWId
path2wid Path
path')
				      (Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
newwindow (Path -> Path -> Path
newChildPath Path
path' Path
rchild))
		     CreateRootWindow Rect
_ String
_ -> 
			 Display
-> XRequest
-> XWId
-> (XWId
    -> SP
         (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a a.
Display
-> XRequest
-> XWId
-> (XWId -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
createWindow Display
disp XRequest
xreq XWId
rootWindow (Path
-> XWId
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
newwindow Path
path')
		     XRequest
_ -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (Request -> Either TEvent (Path, Request)
forall b a. b -> Either a (Path, b)
tox ((Display, XWId, XRequest) -> Request
XRequest (Display
disp, 
				  PathTree XWId -> Path -> XWId
lookupWid PathTree XWId
path2wid Path
path', XRequest
xreq))) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		 LCmd LayoutMessage
_ -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same -- layout pseudo command
	    Right (Path
path', Response
resp) -> case Response
resp of
	      AsyncInput (Descriptor
_, XEvent (XWId
wid, XEvent
event)) ->
		case XEvent
event of
		  XEvent
MappingNotify -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		  ButtonEvent {} -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
checkGrab
		  KeyEvent {} -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
checkGrab
		  MotionNotify {} -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
checkGrab
		  SelectionClear Atom
atom -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. SP a (Either TEvent b) -> SP a (Either TEvent b)
pass (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$ Path
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPns Path
noSel
		  DestroyNotify XWId
w -> if String -> Bool -> Bool
argFlag String
"destroyPrune" Bool
False then
		     SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. SP a (Either TEvent b) -> SP a (Either TEvent b)
pass (SP
   (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
 -> SP
      (Either TCommand (Path, Response)) (Either TEvent (Path, Request)))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Path, Path)
-> PathTree XWId
-> Table (XWId, Path)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagSPs Maybe (Bool, Path, Path)
grabpath PathTree XWId
path2wid' (Table (XWId, Path) -> XWId -> Table (XWId, Path)
forall a b. Ord a => Table (a, b) -> a -> Table (a, b)
prunePath Table (XWId, Path)
wid2path XWId
w)
		    else SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame
		    where path2wid' :: PathTree XWId
path2wid' = if Path -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Path
path2' then PathTree XWId
path2wid
						    else PathTree XWId -> Path -> PathTree XWId
pruneWid PathTree XWId
path2wid Path
path2'
		  XEvent
_ -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame
		where path2' :: Path
path2' = Table (XWId, Path) -> XWId -> Path
forall a. Ord a => Table (a, Path) -> a -> Path
lookupPath Table (XWId, Path)
wid2path XWId
wid
		      passto :: a
-> SP a (Either (a, FResponse) b) -> SP a (Either (a, FResponse) b)
passto a
p = Either (a, FResponse) b
-> SP a (Either (a, FResponse) b) -> SP a (Either (a, FResponse) b)
forall b a. b -> SP a b -> SP a b
putSP ((a, FResponse) -> Either (a, FResponse) b
forall a b. a -> Either a b
Left (a
p, XEvent -> FResponse
XEvt XEvent
event))
		      pass :: SP a (Either TEvent b) -> SP a (Either TEvent b)
pass = Path -> SP a (Either TEvent b) -> SP a (Either TEvent b)
forall a a b.
a
-> SP a (Either (a, FResponse) b) -> SP a (Either (a, FResponse) b)
passto Path
path2'
		      passame :: SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame = SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a b. SP a (Either TEvent b) -> SP a (Either TEvent b)
pass SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
		      checkGrab :: SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
checkGrab = case Maybe (Bool, Path, Path)
grabpath of
				    Maybe (Bool, Path, Path)
Nothing -> SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame
				    Just (Bool
toMe,Path
kpath,Path
path) -> 
				      if Path
path Path -> Path -> Bool
`subPath` Path
path2' then SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame
				      else if Bool
toMe then Path
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall a a b.
a
-> SP a (Either (a, FResponse) b) -> SP a (Either (a, FResponse) b)
passto Path
kpath SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
					   else SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
              XResponse XResponse
xresp -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
path',XResponse -> FResponse
XResp XResponse
xresp)) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
	      SocketResponse SocketResponse
sresp -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
path',SocketResponse -> FResponse
SResp SocketResponse
sresp)) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
	      Response
_ -> Either TEvent (Path, Request)
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
-> SP
     (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
forall b a. b -> SP a b -> SP a b
putSP (TEvent -> Either TEvent (Path, Request)
forall a b. a -> Either a b
Left (Path
path', Response -> FResponse
DResp Response
resp)) SP
  (Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same

newChildPath :: Path -> Path -> Path
newChildPath Path
parent Path
rchild = Path -> Path -> Path
absPath (Path -> Path
forall a. [a] -> [a]
autumnize Path
parent) Path
rchild
  
createWindow :: Display
-> XRequest
-> XWId
-> (XWId -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
createWindow Display
disp XRequest
xreq XWId
wid XWId -> SP (Either a (a, Response)) (Either a (Path, Request))
cont =
    Either a (Path, Request)
-> (Either a (a, Response) -> Maybe XWId)
-> (XWId -> SP (Either a (a, Response)) (Either a (Path, Request)))
-> SP (Either a (a, Response)) (Either a (Path, Request))
forall a b c. a -> (b -> Maybe c) -> Cont (SP b a) c
cmdContSP ((Path, Request) -> Either a (Path, Request)
forall a b. b -> Either a b
Right (Path
here, (Display, XWId, XRequest) -> Request
XRequest (Display
disp, XWId
wid, XRequest
xreq)))
              (\Either a (a, Response)
msg -> case Either a (a, Response)
msg of
                         Right (a
_, XResponse (WindowCreated XWId
wid')) -> XWId -> Maybe XWId
forall a. a -> Maybe a
Just XWId
wid'
                         Either a (a, Response)
_ -> Maybe XWId
forall a. Maybe a
Nothing)
              XWId -> SP (Either a (a, Response)) (Either a (Path, Request))
cont

traceit :: F a b -> F a b
traceit = String -> F a b -> F a b
forall a b. String -> F a b -> F a b
showCommandF String
"debug"

optimizeDrawMany :: Bool
optimizeDrawMany =
  String -> Bool -> Bool
argFlag String
"optdrawmany"
#ifdef __GLASGOW_HASKELL__
    Bool
True
#else
    False
#warning "not optimising DrawMany"
#endif