{-# 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 :: forall i o. F i o -> SP (Path, Response) (Path, Request)
tagEventsSP F i o
mainF =
forall {a1} {b1} {a2} {b2}.
SP (Either a1 b1) (Either a2 b2) -> SP a2 a1 -> SP b1 b2
loopThroughRightSP
SP
(Either TCommand (Path, Response)) (Either TEvent (Path, Request))
tagEventsCtrlSP
(forall {t} {b}. (t -> Maybe b) -> SP t b
mapFilterSP forall {a} {b}. Message a b -> Maybe a
stripLow forall {a1} {b} {a2}. SP a1 b -> SP a2 a1 -> SP a2 b
`serCompSP` FSP i o
mainFSP forall {a} {b} {t}. SP a b -> (t -> a) -> SP t b
`preMapSP` forall a b. a -> Message a b
Low)
where
F FSP i o
mainFSP = 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 forall a. Maybe a -> Bool
isNothing (String -> Maybe String
getEnvi String
"DISPLAY")
then Display -> SP (Either a (a, Response)) (Either a (Path, Request))
cont forall {a}. a
faildisp
else
forall a b c. a -> (b -> Maybe c) -> Cont (SP b a) c
cmdContSP (forall {b} {a}. b -> Either a (Path, b)
tox 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)) -> forall a. a -> Maybe a
Just Display
d
Right (a
_, Failure IOError
f) -> forall a. HasCallStack => String -> a
error (String
"Cannot open the display (the program is probably not linked with the X routines): "forall a. [a] -> [a] -> [a]
++IOError -> String
showFailure IOError
f)
Either a (a, Response)
_ -> forall a. Maybe a
Nothing)
(\Display
disp ->
if Display
disp forall a. Eq a => a -> a -> Bool
== Int -> Display
Display Int
0 then
forall a. HasCallStack => String -> a
error String
"Cannot open display"
else
forall b a. b -> SP a b -> SP a b
putSP (forall {b} {a}. b -> Either a (Path, b)
tox forall a b. (a -> b) -> a -> b
$ [Descriptor] -> Request
Select [Display -> Descriptor
DisplayDe Display
disp]) forall a b. (a -> b) -> a -> b
$ Display -> SP (Either a (a, Response)) (Either a (Path, Request))
cont Display
disp)
where faildisp :: a
faildisp = forall a. HasCallStack => String -> a
error String
"the environment variable DISPLAY is not set!"
tox :: b -> Either a (Path, b)
tox b
x = 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 =
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 forall a. Maybe a
Nothing forall {n}. PathTree n
path2wid0 forall {k} {v}. Table k v
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 forall a b. Cont (SP a b) a
getSP 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 =
forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
path'', XResponse -> FResponse
XResp (XWId -> XResponse
WindowCreated XWId
wid))) 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 = 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 = 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 = forall b a. b -> SP a b -> SP a b
putSP (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)
(forall {k} {v}. Ord k => Table k v -> k -> v -> Table k v
updatePath Table XWId Path
wid2path XWId
w Path
p)
in case FRequest
cmd of
XCmd xcmd :: XCommand
xcmd@(SetSelectionOwner Bool
s Atom
atom) ->
forall {a} {a}.
XCommand
-> SP a (Either a (Path, Request))
-> SP a (Either a (Path, Request))
convertcmd XCommand
xcmd forall a b. (a -> b) -> a -> b
$
(if Bool
s Bool -> Bool -> Bool
&& Path
selp forall a. Eq a => a -> a -> Bool
/= Path
noSel Bool -> Bool -> Bool
&& Path
path' forall a. Eq a => a -> a -> Bool
/= Path
selp then
forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
selp,XEvent -> FResponse
XEvt (Atom -> XEvent
SelectionClear Atom
atom))) else forall a. a -> a
id) 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 = forall {a}. [a] -> [a]
autumnize Path
npath'
wpath :: Path
wpath = forall {a}. Ord a => Table a Path -> a -> Path
lookupPath Table XWId Path
wid2path XWId
w
opath :: Path
opath = 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 = forall {k}. Table k Path -> Path -> Path -> Table k Path
movePaths Table XWId Path
wid2path Path
opath Path
npath
in 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) forall a b. (a -> b) -> a -> b
$
if 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 -> forall b a. b -> SP a b -> SP a b
putSP (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 ->
forall b a. [b] -> SP a b -> SP a b
putsSP [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) -> forall {p} {p}. p -> p -> p
mtrace (String
"Grab",Bool
toMe,Either TCommand (Path, Response)
msg) 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 (forall a. a -> Maybe a
Just (Bool
toMe,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 forall a. Maybe a
Nothing PathTree XWId
path2wid Table XWId Path
wid2path
XCmd (DrawMany Drawable
w [(GCId, [DrawCommand])]
gcdcmdss) | Bool -> Bool
not Bool
optimizeDrawMany ->
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 -> 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 -> forall b a. b -> SP a b -> SP a b
putSP (forall {b} {a}. b -> Either a (Path, b)
tox Request
req) SP
(Either TCommand (Path, Response)) (Either TEvent (Path, Request))
same
SReq SocketRequest
sreq -> forall b a. b -> SP a b -> SP a b
putSP (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
_ -> forall a. HasCallStack => String -> a
error String
"GUI fudget outside a shell fudget"
CreateSimpleWindow Path
rchild Rect
_ ->
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
_ ->
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
_ -> forall b a. b -> SP a b -> SP a b
putSP (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 -> forall {a} {b}. SP a (Either TEvent b) -> SP a (Either TEvent b)
pass 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
forall {a} {b}. SP a (Either TEvent b) -> SP a (Either TEvent b)
pass 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' (forall {b} {v}. Ord b => Table b v -> b -> Table b v
prunePath Table XWId Path
wid2path XWId
w)
else SP
(Either TCommand (Path, Response)) (Either TEvent (Path, Request))
passame
where path2wid' :: PathTree XWId
path2wid' = if 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' = 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 = forall b a. b -> SP a b -> SP a b
putSP (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 = 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 = 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 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 -> forall b a. b -> SP a b -> SP a b
putSP (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 -> forall b a. b -> SP a b -> SP a b
putSP (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
_ -> forall b a. b -> SP a b -> SP a b
putSP (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 (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 =
forall a b c. a -> (b -> Maybe c) -> Cont (SP b a) c
cmdContSP (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')) -> forall a. a -> Maybe a
Just XWId
wid'
Either a (a, Response)
_ -> forall a. Maybe a
Nothing)
XWId -> SP (Either a (a, Response)) (Either a (Path, Request))
cont
traceit :: F a b -> F a b
traceit = 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