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 =
    forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither forall {a} {b}. EqSnd a b -> a
fstEqSnd forall a. a -> a
idforall a b e. (a -> b) -> F e a -> F e b
>^=<
    forall {b} {b} {t :: * -> *} {b} {c} {d} {b}.
(Eq b, Graphic b, Foldable t) =>
ColorName
-> Bool
-> ColorName
-> Button
-> ModState
-> t (ModState, 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) [] []
                  (forall {a} {b} {a}. [(a, b)] -> [(EqSnd a b, [a])]
pre [(a, b)]
alts) forall {a} {b}. EqSnd a b -> b
sndEqSnd F c b
f
    forall c d e. F c d -> (e -> c) -> F e d
>=^< forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither forall {a} {b} {a}. [(a, b)] -> [(EqSnd a b, [a])]
pre forall a. a -> a
id
  where
    pre :: [(a, b)] -> [(EqSnd a b, [a])]
pre = forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b}. a -> b -> (a, b)
`pair` []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. [(a, b)] -> [EqSnd a b]
toEqSnd

oldPopupMenuF :: ColorName
-> Bool
-> ColorName
-> Button
-> ModState
-> t (ModState, 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 ModState
mods t (ModState, ColorName)
keys [(b, b)]
alts b -> b
show_alt F c d
f = 
 forall a b c. F (Either a b) (Either b c) -> F a c
serCompLeftToRightF forall a b. (a -> b) -> a -> b
$
 forall {t :: * -> *} {b} {b} {b} {c} {d} {a} {a} {b}.
(Eq b, Graphic b, Foldable t) =>
ColorName
-> Bool
-> ColorName
-> Button
-> ModState
-> t (ModState, ColorName)
-> [(b, b)]
-> (b -> b)
-> F c d
-> F (Either (Either a a) (Either (Either [(b, b)] PopupMenu) c))
     (Either (Either (Either a PopupMenu) a) (Either b d))
oldPopupMenuF' ColorName
bgcolor Bool
grab ColorName
fname Button
button ModState
mods t (ModState, ColorName)
keys [(b, b)]
alts b -> b
show_alt F c d
f

oldPopupMenuF' :: ColorName
-> Bool
-> ColorName
-> Button
-> ModState
-> t (ModState, ColorName)
-> [(b, b)]
-> (b -> b)
-> F c d
-> F (Either (Either a a) (Either (Either [(b, b)] PopupMenu) c))
     (Either (Either (Either a PopupMenu) a) (Either b d))
oldPopupMenuF' ColorName
bgcolor Bool
grab ColorName
fname Button
button ModState
mods t (ModState, 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 -> ModState -> [EventMask] -> XCommand
GrabButton Bool
True Button
button ModState
mods [EventMask]
grabeventmask]
	          else []
        eventmask :: [EventMask]
eventmask =
	  (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (ModState, ColorName)
keys then [] else [EventMask
KeyPressMask, EventMask
KeyReleaseMask]) forall a. [a] -> [a] -> [a]
++
          (if Bool
grab then [] else (EventMask
OwnerGrabButtonMaskforall a. a -> [a] -> [a]
:[EventMask]
grabeventmask)) forall a. [a] -> [a] -> [a]
++
	  [EventMask
LeaveWindowMask]
        startcmds :: [XCommand]
startcmds = [XCommand]
grabcmd forall a. [a] -> [a] -> [a]
++ [[WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask]]
        ungrab :: SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
ungrab = forall {t} {b}. (t -> [b]) -> SP t b
concatMapSP 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) = [forall a b. b -> Message a b
High b
m,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 = forall {b}. F (Either [(b, b)] PopupMenu) b
dynAltsF
	dynAltsF :: F (Either [(b, b)] PopupMenu) b
dynAltsF =
	    forall a b. F a b -> F (Either (F a b) a) b
dynF (forall {b}. [(b, b)] -> F PopupMenu b
altsF [(b, b)]
alts) forall c d e. F c d -> (e -> c) -> F e d
>=^< forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> Either t1 t2 -> Either a b
mapEither forall {b}. [(b, b)] -> F PopupMenu b
altsF forall a. a -> a
id
	  where
	    altsF :: [(b, b)] -> F PopupMenu b
altsF [(b, b)]
alts' = forall {hi} {ho}. F hi ho -> F hi ho
delayF' (forall {d} {b}.
(Eq d, Graphic b) =>
ColorName -> [d] -> (d -> b) -> F PopupMenu d
menuAltsF ColorName
fname (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall {hi} {ho}. F hi ho -> F hi ho
delayF F hi ho
f forall {hi} {ho}. F hi ho -> SP TEvent TEvent -> F hi ho
>=..< forall {b}. (b -> Bool) -> SP b b
filterSP 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  (forall {a} {b} {c} {d}.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF (forall a b. (a -> b) -> [a] -> [b]
map XCommand -> FRequest
XCmd [XCommand]
startcmds)
               (forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgcolor (forall {t :: * -> *} {p} {a} {a}.
Foldable t =>
p
-> Button
-> t (ModState, ColorName)
-> ModState
-> K (Either a a) (Either (Either a PopupMenu) a)
actionK Bool
grab Button
button t (ModState, ColorName)
keys ModState
mods))
               (forall hi ho. FSP hi ho -> F hi ho
F{-ff-} (forall {b}.
SP (Message (Path, FRequest) b) (Message (Path, FRequest) b)
ungrab forall {a1} {b} {a2}. SP a1 b -> SP a2 a1 -> SP a2 b
`serCompSP` forall {b}. FSP (Either [(b, b)] PopupMenu) b
dynAltsFSP) 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 (ModState, ColorName)
-> ModState
-> K (Either a a) (Either (Either a PopupMenu) a)
actionK p
grab Button
button t (ModState, ColorName)
keys ModState
mods = forall hi ho. KSP hi ho -> K hi ho
K{-kk-} forall a b. (a -> b) -> a -> b
$ forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {a} {a}.
Message FResponse (Either a a)
-> [Message FRequest (Either (Either a PopupMenu) a)]
action where
    toF :: a -> Message a (Either a a)
toF = forall a b. b -> Message a b
High forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    toMenu :: a -> Message a (Either (Either a a) b)
toMenu = forall a b. b -> Message a b
High forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    newMenu :: a -> Message a (Either (Either a b) b)
newMenu = forall a b. b -> Message a b
High forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
    action :: Message FResponse (Either a a)
-> [Message FRequest (Either (Either a PopupMenu) a)]
action Message FResponse (Either a a)
msg = case Message FResponse (Either a a)
msg of
      High (Right a
hmsg) -> [forall {a} {a} {a}. a -> Message a (Either a a)
toF a
hmsg]
      High (Left a
alts) -> [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 -> ModState
state=ModState
m,type' :: XEvent -> Pressed
type'=Pressed
Pressed,button :: XEvent -> Button
button=Button
b} | ModState
m forall a. Eq a => a -> a -> Bool
== ModState
mods Bool -> Bool -> Bool
&& Button
b forall a. Eq a => a -> a -> Bool
== Button
button -> 
	       [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd (Bool -> XCommand
GrabEvents Bool
True),forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu (Point -> XEvent -> PopupMenu
PopupMenu Point
rootPos XEvent
ev)]
        KeyEvent {rootPos :: XEvent -> Point
rootPos=Point
rootPos,state :: XEvent -> ModState
state=ModState
m,type' :: XEvent -> Pressed
type'=Pressed
Pressed,keySym :: XEvent -> ColorName
keySym=ColorName
ks} | (ModState
m, ColorName
ks) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t (ModState, ColorName)
keys -> 
	       [forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu (Point -> XEvent -> PopupMenu
PopupMenu Point
rootPos XEvent
ev)]
        LeaveNotify {mode :: XEvent -> Mode
mode=Mode
NotifyUngrab} -> 
	       [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UngrabEvents,forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu PopupMenu
PopdownMenu]
        ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Released} -> 
	       [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UngrabEvents,forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu PopupMenu
PopdownMenu]
        KeyEvent {type' :: XEvent -> Pressed
type'=Pressed
Released} -> [forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu PopupMenu
PopdownMenu]
        XEvent
_ -> []
      Low FResponse
_ -> []