module PopupMenuF(popupMenuF,oldPopupMenuF,oldPopupMenuF') where
import Command
import CompOps((>=^<), (>^=<),(>+<))
import InfixOps((>=..<))
import Dlayout(groupF)
import Event
import Fudget
import FRequest
import GreyBgF(changeBg)
import MenuF(menuAltsF,toEqSnd,fstEqSnd,sndEqSnd)
import MenuPopupF(PopupMenu(..))
import DynListF(dynF)
import Path(here)
import SerCompF(serCompLeftToRightF)
import Spops
import EitherUtils(mapEither)
import Xtypes
import CompSP(serCompSP)
import Defaults(bgColor,menuFont)
import Utils(pair)
import NullF(delayF)
[(a, b)]
alts F c b
f =
(EqSnd a b -> a) -> (b -> b) -> Either (EqSnd a b) b -> Either a b
forall t1 a t2 b.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither EqSnd a b -> a
forall a b. EqSnd a b -> a
fstEqSnd b -> b
forall a. a -> a
id(Either (EqSnd a b) b -> Either a b)
-> F (Either [(EqSnd a b, [Any])] c) (Either (EqSnd a b) b)
-> F (Either [(EqSnd a b, [Any])] c) (Either a b)
forall a b e. (a -> b) -> F e a -> F e b
>^=<
ColorName
-> Bool
-> ColorName
-> Button
-> [Modifiers]
-> [([Modifiers], ColorName)]
-> [(EqSnd a b, [Any])]
-> (EqSnd a b -> b)
-> F c b
-> F (Either [(EqSnd a b, [Any])] c) (Either (EqSnd a b) b)
forall b b (t :: * -> *) b c d b.
(Eq b, Graphic b, Foldable t) =>
ColorName
-> Bool
-> ColorName
-> Button
-> [Modifiers]
-> t ([Modifiers], ColorName)
-> [(b, b)]
-> (b -> b)
-> F c d
-> F (Either [(b, b)] c) (Either b d)
oldPopupMenuF ColorName
bgColor Bool
True ColorName
menuFont (Int -> Button
Button Int
3) [] []
([(a, b)] -> [(EqSnd a b, [Any])]
forall a b a. [(a, b)] -> [(EqSnd a b, [a])]
pre [(a, b)]
alts) EqSnd a b -> b
forall a b. EqSnd a b -> b
sndEqSnd F c b
f
F (Either [(EqSnd a b, [Any])] c) (Either a b)
-> (Either [(a, b)] c -> Either [(EqSnd a b, [Any])] c)
-> F (Either [(a, b)] c) (Either a b)
forall c d e. F c d -> (e -> c) -> F e d
>=^< ([(a, b)] -> [(EqSnd a b, [Any])])
-> (c -> c) -> Either [(a, b)] c -> Either [(EqSnd a b, [Any])] c
forall t1 a t2 b.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither [(a, b)] -> [(EqSnd a b, [Any])]
forall a b a. [(a, b)] -> [(EqSnd a b, [a])]
pre c -> c
forall a. a -> a
id
where
pre :: [(a, b)] -> [(EqSnd a b, [a])]
pre = (EqSnd a b -> (EqSnd a b, [a]))
-> [EqSnd a b] -> [(EqSnd a b, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (EqSnd a b -> [a] -> (EqSnd a b, [a])
forall a b. a -> b -> (a, b)
`pair` []) ([EqSnd a b] -> [(EqSnd a b, [a])])
-> ([(a, b)] -> [EqSnd a b]) -> [(a, b)] -> [(EqSnd a b, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> [EqSnd a b]
forall a b. [(a, b)] -> [EqSnd a b]
toEqSnd
ColorName
bgcolor Bool
grab ColorName
fname Button
button [Modifiers]
mods t ([Modifiers], ColorName)
keys [(b, b)]
alts b -> b
show_alt F c d
f =
F (Either
(Either [(b, b)] c) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either [(b, b)] PopupMenu) c) (Either b d))
-> F (Either [(b, b)] c) (Either b d)
forall a b c. F (Either a b) (Either b c) -> F a c
serCompLeftToRightF (F (Either
(Either [(b, b)] c) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either [(b, b)] PopupMenu) c) (Either b d))
-> F (Either [(b, b)] c) (Either b d))
-> F (Either
(Either [(b, b)] c) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either [(b, b)] PopupMenu) c) (Either b d))
-> F (Either [(b, b)] c) (Either b d)
forall a b. (a -> b) -> a -> b
$
ColorName
-> Bool
-> ColorName
-> Button
-> [Modifiers]
-> t ([Modifiers], ColorName)
-> [(b, b)]
-> (b -> b)
-> F c d
-> F (Either
(Either [(b, b)] c) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either [(b, b)] PopupMenu) c) (Either b d))
forall (t :: * -> *) b b b c d a b b.
(Eq b, Graphic b, Foldable t) =>
ColorName
-> Bool
-> ColorName
-> Button
-> [Modifiers]
-> t ([Modifiers], ColorName)
-> [(b, b)]
-> (b -> b)
-> F c d
-> F (Either (Either a b) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either a PopupMenu) b) (Either b d))
oldPopupMenuF' ColorName
bgcolor Bool
grab ColorName
fname Button
button [Modifiers]
mods t ([Modifiers], ColorName)
keys [(b, b)]
alts b -> b
show_alt F c d
f
ColorName
bgcolor Bool
grab ColorName
fname Button
button [Modifiers]
mods t ([Modifiers], ColorName)
keys [(b, b)]
alts b -> b
show_alt F c d
f =
let grabeventmask :: [EventMask]
grabeventmask = [EventMask
ButtonPressMask, EventMask
ButtonReleaseMask]
grabcmd :: [XCommand]
grabcmd = if Bool
grab then [Bool -> Button -> [Modifiers] -> [EventMask] -> XCommand
GrabButton Bool
True Button
button [Modifiers]
mods [EventMask]
grabeventmask]
else []
eventmask :: [EventMask]
eventmask =
(if t ([Modifiers], ColorName) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t ([Modifiers], ColorName)
keys then [] else [EventMask
KeyPressMask, EventMask
KeyReleaseMask]) [EventMask] -> [EventMask] -> [EventMask]
forall a. [a] -> [a] -> [a]
++
(if Bool
grab then [] else (EventMask
OwnerGrabButtonMaskEventMask -> [EventMask] -> [EventMask]
forall a. a -> [a] -> [a]
:[EventMask]
grabeventmask)) [EventMask] -> [EventMask] -> [EventMask]
forall a. [a] -> [a] -> [a]
++
[EventMask
LeaveWindowMask]
startcmds :: [XCommand]
startcmds = [XCommand]
grabcmd [XCommand] -> [XCommand] -> [XCommand]
forall a. [a] -> [a] -> [a]
++ [[WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask]]
ungrab :: SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
ungrab = (Message (Path, FRequest) b -> [Message (Path, FRequest) b])
-> SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
forall t b. (t -> [b]) -> SP t b
concatMapSP Message (Path, FRequest) b -> [Message (Path, FRequest) b]
forall b.
Message (Path, FRequest) b -> [Message (Path, FRequest) b]
un where
un :: Message (Path, FRequest) b -> [Message (Path, FRequest) b]
un (High b
m) = [b -> Message (Path, FRequest) b
forall a b. b -> Message a b
High b
m,(Path, FRequest) -> Message (Path, FRequest) b
forall a b. a -> Message a b
Low (Path
here,XCommand -> FRequest
XCmd XCommand
UngrabEvents)]
un Message (Path, FRequest) b
m = [Message (Path, FRequest) b
m]
F FSP (Either [(b, b)] PopupMenu) b
dynAltsFSP = F (Either [(b, b)] PopupMenu) b
forall b. F (Either [(b, b)] PopupMenu) b
dynAltsF
dynAltsF :: F (Either [(b, b)] PopupMenu) b
dynAltsF =
F PopupMenu b -> F (Either (F PopupMenu b) PopupMenu) b
forall a b. F a b -> F (Either (F a b) a) b
dynF ([(b, b)] -> F PopupMenu b
forall b. [(b, b)] -> F PopupMenu b
altsF [(b, b)]
alts) F (Either (F PopupMenu b) PopupMenu) b
-> (Either [(b, b)] PopupMenu -> Either (F PopupMenu b) PopupMenu)
-> F (Either [(b, b)] PopupMenu) b
forall c d e. F c d -> (e -> c) -> F e d
>=^< ([(b, b)] -> F PopupMenu b)
-> (PopupMenu -> PopupMenu)
-> Either [(b, b)] PopupMenu
-> Either (F PopupMenu b) PopupMenu
forall t1 a t2 b.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither [(b, b)] -> F PopupMenu b
forall b. [(b, b)] -> F PopupMenu b
altsF PopupMenu -> PopupMenu
forall a. a -> a
id
where
altsF :: [(b, b)] -> F PopupMenu b
altsF [(b, b)]
alts' = F PopupMenu b -> F PopupMenu b
forall hi ho. F hi ho -> F hi ho
delayF' (ColorName -> [b] -> (b -> b) -> F PopupMenu b
forall d b.
(Eq d, Graphic b) =>
ColorName -> [d] -> (d -> b) -> F PopupMenu d
menuAltsF ColorName
fname (((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, b) -> b
forall a b. (a, b) -> a
fst [(b, b)]
alts') b -> b
show_alt)
delayF' :: F hi ho -> F hi ho
delayF' F hi ho
f = F hi ho -> F hi ho
forall hi ho. F hi ho -> F hi ho
delayF F hi ho
f F hi ho -> SP TEvent TEvent -> F hi ho
forall hi ho. F hi ho -> SP TEvent TEvent -> F hi ho
>=..< (TEvent -> Bool) -> SP TEvent TEvent
forall b. (b -> Bool) -> SP b b
filterSP TEvent -> Bool
forall a. (a, FResponse) -> Bool
notDestroy
notDestroy :: (a, FResponse) -> Bool
notDestroy (a
_,XEvt (DestroyNotify Window
_)) = Bool
False
notDestroy (a, FResponse)
_ = Bool
True
in ([FRequest]
-> K (Either a b) (Either (Either a PopupMenu) b)
-> F (Either (Either [(b, b)] PopupMenu) c) (Either b d)
-> F (Either (Either a b) (Either (Either [(b, b)] PopupMenu) c))
(Either (Either (Either a PopupMenu) b) (Either b d))
forall a b c d.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF ((XCommand -> FRequest) -> [XCommand] -> [FRequest]
forall a b. (a -> b) -> [a] -> [b]
map XCommand -> FRequest
XCmd [XCommand]
startcmds)
(ColorName
-> K (Either a b) (Either (Either a PopupMenu) b)
-> K (Either a b) (Either (Either a PopupMenu) b)
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgcolor (Bool
-> Button
-> t ([Modifiers], ColorName)
-> [Modifiers]
-> K (Either a b) (Either (Either a PopupMenu) b)
forall (t :: * -> *) p a b.
Foldable t =>
p
-> Button
-> t ([Modifiers], ColorName)
-> [Modifiers]
-> K (Either a b) (Either (Either a PopupMenu) b)
actionK Bool
grab Button
button t ([Modifiers], ColorName)
keys [Modifiers]
mods))
(FSP (Either [(b, b)] PopupMenu) b
-> F (Either [(b, b)] PopupMenu) b
forall hi ho. FSP hi ho -> F hi ho
F (SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
forall b.
SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
ungrab SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
-> FSP (Either [(b, b)] PopupMenu) b
-> FSP (Either [(b, b)] PopupMenu) b
forall a1 b a2. SP a1 b -> SP a2 a1 -> SP a2 b
`serCompSP` FSP (Either [(b, b)] PopupMenu) b
forall b. FSP (Either [(b, b)] PopupMenu) b
dynAltsFSP) F (Either [(b, b)] PopupMenu) b
-> F c d -> F (Either (Either [(b, b)] PopupMenu) c) (Either b d)
forall a b c d. F a b -> F c d -> F (Either a c) (Either b d)
>+< F c d
f))
actionK :: p
-> Button
-> t ([Modifiers], ColorName)
-> [Modifiers]
-> K (Either a b) (Either (Either a PopupMenu) b)
actionK p
grab Button
button t ([Modifiers], ColorName)
keys [Modifiers]
mods = KSP (Either a b) (Either (Either a PopupMenu) b)
-> K (Either a b) (Either (Either a PopupMenu) b)
forall hi ho. KSP hi ho -> K hi ho
K (KSP (Either a b) (Either (Either a PopupMenu) b)
-> K (Either a b) (Either (Either a PopupMenu) b))
-> KSP (Either a b) (Either (Either a PopupMenu) b)
-> K (Either a b) (Either (Either a PopupMenu) b)
forall a b. (a -> b) -> a -> b
$ (Message FResponse (Either a b)
-> [Message FRequest (Either (Either a PopupMenu) b)])
-> KSP (Either a b) (Either (Either a PopupMenu) b)
forall t b. (t -> [b]) -> SP t b
concmapSP Message FResponse (Either a b)
-> [Message FRequest (Either (Either a PopupMenu) b)]
forall a b.
Message FResponse (Either a b)
-> [Message FRequest (Either (Either a PopupMenu) b)]
action where
toF :: b -> Message a (Either a b)
toF = Either a b -> Message a (Either a b)
forall a b. b -> Message a b
High (Either a b -> Message a (Either a b))
-> (b -> Either a b) -> b -> Message a (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right
toMenu :: b -> Message a (Either (Either a b) b)
toMenu = Either (Either a b) b -> Message a (Either (Either a b) b)
forall a b. b -> Message a b
High (Either (Either a b) b -> Message a (Either (Either a b) b))
-> (b -> Either (Either a b) b)
-> b
-> Message a (Either (Either a b) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either (Either a b) b
forall a b. a -> Either a b
Left (Either a b -> Either (Either a b) b)
-> (b -> Either a b) -> b -> Either (Either a b) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right
newMenu :: a -> Message a (Either (Either a b) b)
newMenu = Either (Either a b) b -> Message a (Either (Either a b) b)
forall a b. b -> Message a b
High (Either (Either a b) b -> Message a (Either (Either a b) b))
-> (a -> Either (Either a b) b)
-> a
-> Message a (Either (Either a b) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either (Either a b) b
forall a b. a -> Either a b
Left (Either a b -> Either (Either a b) b)
-> (a -> Either a b) -> a -> Either (Either a b) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
action :: Message FResponse (Either a b)
-> [Message FRequest (Either (Either a PopupMenu) b)]
action Message FResponse (Either a b)
msg = case Message FResponse (Either a b)
msg of
High (Right b
hmsg) -> [b -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a. b -> Message a (Either a b)
toF b
hmsg]
High (Left a
alts) -> [a -> Message FRequest (Either (Either a PopupMenu) b)
forall a a b b. a -> Message a (Either (Either a b) b)
newMenu a
alts]
Low (XEvt XEvent
ev) -> case XEvent
ev of
ButtonEvent {rootPos :: XEvent -> Point
rootPos=Point
rootPos,state :: XEvent -> [Modifiers]
state=[Modifiers]
m,type' :: XEvent -> Pressed
type'=Pressed
Pressed,button :: XEvent -> Button
button=Button
b} | [Modifiers]
m [Modifiers] -> [Modifiers] -> Bool
forall a. Eq a => a -> a -> Bool
== [Modifiers]
mods Bool -> Bool -> Bool
&& Button
b Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
button ->
[FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. a -> Message a b
Low (FRequest -> Message FRequest (Either (Either a PopupMenu) b))
-> FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd (Bool -> XCommand
GrabEvents Bool
True),PopupMenu -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a b. b -> Message a (Either (Either a b) b)
toMenu (Point -> XEvent -> PopupMenu
PopupMenu Point
rootPos XEvent
ev)]
KeyEvent {rootPos :: XEvent -> Point
rootPos=Point
rootPos,state :: XEvent -> [Modifiers]
state=[Modifiers]
m,type' :: XEvent -> Pressed
type'=Pressed
Pressed,keySym :: XEvent -> ColorName
keySym=ColorName
ks} | ([Modifiers]
m, ColorName
ks) ([Modifiers], ColorName) -> t ([Modifiers], ColorName) -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t ([Modifiers], ColorName)
keys ->
[PopupMenu -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a b. b -> Message a (Either (Either a b) b)
toMenu (Point -> XEvent -> PopupMenu
PopupMenu Point
rootPos XEvent
ev)]
LeaveNotify {mode :: XEvent -> Mode
mode=Mode
NotifyUngrab} ->
[FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. a -> Message a b
Low (FRequest -> Message FRequest (Either (Either a PopupMenu) b))
-> FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UngrabEvents,PopupMenu -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a b. b -> Message a (Either (Either a b) b)
toMenu PopupMenu
PopdownMenu]
ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Released} ->
[FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. a -> Message a b
Low (FRequest -> Message FRequest (Either (Either a PopupMenu) b))
-> FRequest -> Message FRequest (Either (Either a PopupMenu) b)
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UngrabEvents,PopupMenu -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a b. b -> Message a (Either (Either a b) b)
toMenu PopupMenu
PopdownMenu]
KeyEvent {type' :: XEvent -> Pressed
type'=Pressed
Released} -> [PopupMenu -> Message FRequest (Either (Either a PopupMenu) b)
forall b a a b. b -> Message a (Either (Either a b) b)
toMenu PopupMenu
PopdownMenu]
XEvent
_ -> []
Low FResponse
_ -> []