{-# LANGUAGE CPP #-}
module TagEvents(tagEventsSP) where
import Command
import CompSP(preMapSP,serCompSP)
import SpEither(mapFilterSP)
import Cont(cmdContSP)
import CmdLineEnv(argFlag)
import Event
import Fudget
import FRequest
import IOUtil(getEnvi)
import Loopthrough
import Message(stripLow)
import Path
import WindowF(autumnize)
import ShowCommandF
import Sockets
import Spops
import Tables
import Xtypes
import Data.Maybe(isNothing)
import ShowFailure
import DialogueIO
import Prelude hiding (IOError)
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) ->
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) ->
let npath' :: Path
npath' = Path -> Path -> Path
newChildPath Path
path' Path
rchild
npath :: Path
npath = Path -> Path
forall a. [a] -> [a]
autumnize Path
npath'
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 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
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
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