module PopupMenuF(popupMenuF,oldPopupMenuF,oldPopupMenuF') where
--import ButtonGroupF
import Command
import CompOps((>=^<), (>^=<),(>+<))--(>==<), 
import InfixOps((>=..<))--(>^^=<),
import Dlayout(groupF)
import Event
--import Font(FontStruct)
import Fudget
import FRequest
--import Geometry(Line, Point, Rect, Size(..))
import GreyBgF(changeBg)
--import LayoutRequest(LayoutRequest)
import MenuF(menuAltsF,toEqSnd,fstEqSnd,sndEqSnd)--EqSnd,
import MenuPopupF(PopupMenu(..))
import DynListF(dynF)
--import Message(Message(..))
import Path(here)
import SerCompF(serCompLeftToRightF)--idRightF,
import Spops
import EitherUtils(mapEither)
import Xtypes
import CompSP(serCompSP)
import Defaults(bgColor,menuFont)
import Utils(pair)
import NullF(delayF)
--import ShowCommandF(showCommandF) -- debugging
--import SpyF(teeF) -- debugging

--popupMenuF :: [(alt,String)] -> F i o -> F (Either x i) (Either alt o)
popupMenuF :: [(a, b)] -> F c b -> F (Either [(a, b)] c) (Either a b)
popupMenuF [(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

oldPopupMenuF :: 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
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

oldPopupMenuF' :: 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 =
    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)
	     -- !! keyboard shortcuts ignored !!
	    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
	    --delayF' = id
	    --delayF' f = delayF (showCommandF "altsF" f >==< teeF show "altsF: ")
	    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{-ff-} (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{-kk-} (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] -- breaks backwards compatibility...
      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
_ -> []