module MenuPopupF(PopupMenu(..), menuPopupF, menuPopupF') where
import Command
import Cursor
import Shells(unmappedShellF')
import FDefaults() -- synonym Customiser, for hbc
import DShellF(setFocusMgr)
import Event
import Fudget
import FRequest
import Geometry(Point)
import Loops(loopCompThroughRightF,loopThroughRightF)
--import Message(Message(..))
import CompSP(prepostMapSP)
import SerCompF(mapstateF)
import NullF
import Xtypes
import Data.List(union)

data PopupMenu
  = PopupMenu Point XEvent -- Time to pop up the menu.
  | PopupMenuStick	   -- The mouse button has been released, but stay up.
  | PopdownMenu		   -- Time to hide the menu.
  deriving Int -> PopupMenu -> ShowS
[PopupMenu] -> ShowS
PopupMenu -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PopupMenu] -> ShowS
$cshowList :: [PopupMenu] -> ShowS
show :: PopupMenu -> String
$cshow :: PopupMenu -> String
showsPrec :: Int -> PopupMenu -> ShowS
$cshowsPrec :: Int -> PopupMenu -> ShowS
Show
  --deriving (Eq, Ord)

menuPopupF :: F b d -> F (Either PopupMenu b) d
menuPopupF = forall {b} {d}. Bool -> F b d -> F (Either PopupMenu b) d
menuPopupF' Bool
False

menuPopupF' :: Bool -> F b d -> F (Either PopupMenu b) d
menuPopupF' Bool
delayed F b d
menu =
    forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (forall {hi} {ho}. F hi ho -> F hi ho
dF forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a} {b} {c} {d}.
Foldable t =>
(ShellF -> ShellF)
-> t FRequest -> K a b -> F c d -> F (Either a c) (Either b d)
unmappedShellF' ShellF -> ShellF
pm [FRequest]
startcmds forall {b} {b}.
K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
popupShellK F (Either Bool b) d
menu')
  where
    dF :: F hi ho -> F hi ho
dF = if Bool
delayed then forall {hi} {ho}. F hi ho -> F hi ho
delayF else forall a. a -> a
id
    pm :: ShellF -> ShellF
pm = Bool -> ShellF -> ShellF
setFocusMgr Bool
False
    menu' :: F (Either Bool b) d
menu' = forall {b} {d}. F b d -> F (Either Bool b) d
handleButtonMachinesF F b d
menu
    startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs,
		 XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
1]]
    wattrs :: [WindowAttributes]
wattrs = [[EventMask] -> WindowAttributes
CWEventMask [], Bool -> WindowAttributes
CWSaveUnder Bool
True, Bool -> WindowAttributes
CWOverrideRedirect Bool
True]

popupShellK :: K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
popupShellK =
    forall a b. Int -> K a b -> K a b
setFontCursor Int
110 forall {b} {b}.
K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
  where
    mouse :: XEvent -> Bool
mouse (ButtonEvent {}) = Bool
True
    mouse (EnterNotify {}) = Bool
True
    mouse XEvent
_ = Bool
False
    samekey :: XEvent -> String -> Bool
samekey (KeyEvent {keySym :: XEvent -> String
keySym=String
ks}) String
ks' = String
ks forall a. Eq a => a -> a -> Bool
== String
ks'
    samekey XEvent
_ String
_ = Bool
False

    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
    toBms :: a -> Message a (Either (Either a b) b)
toBms = 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
    out :: a -> Message a (Either a a)
out = 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

    popdown :: [Message FRequest b]
popdown = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd) [XCommand
UnmapWindow]
    popup :: Point -> [Message FRequest (Either (Either Bool b) b)]
popup Point
p = forall {a} {a} {b} {b}. a -> Message a (Either (Either a b) b)
toBms Bool
Trueforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd) [Point -> XCommand
moveWindow Point
p, XCommand
MapRaised]

    downK :: K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK =
      forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent (Either b (Either PopupMenu b))
msg ->
      case KEvent (Either b (Either PopupMenu b))
msg of
	High (Right (Left (PopupMenu Point
p XEvent
ev))) -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b} {b}.
Point -> [Message FRequest (Either (Either Bool b) b)]
popup Point
p)     forall a b. (a -> b) -> a -> b
$ XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	High (Right (Right b
x))               -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK  (forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu b
x)    forall a b. (a -> b) -> a -> b
$ K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
	High (Left b
x)                        -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK  (forall {a} {a} {a}. a -> Message a (Either a a)
out b
x)       forall a b. (a -> b) -> a -> b
$ K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
	KEvent (Either b (Either PopupMenu b))
_ -> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK

    upK :: XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev =
      forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent (Either b (Either PopupMenu b))
msg ->
      case KEvent (Either b (Either PopupMenu b))
msg of
	High (Right (Left (PopupMenu Point
p XEvent
ev))) -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b} {b}.
Point -> [Message FRequest (Either (Either Bool b) b)]
popup Point
p)     forall a b. (a -> b) -> a -> b
$ XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	High (Right (Left PopupMenu
PopdownMenu))      -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK forall {b}. [Message FRequest b]
popdown       forall a b. (a -> b) -> a -> b
$ K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
	High (Right (Left PopupMenu
PopupMenuStick))   -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK  (forall {a} {a} {b} {b}. a -> Message a (Either (Either a b) b)
toBms Bool
False) forall a b. (a -> b) -> a -> b
$ XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	High (Right (Right b
x))               -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK  (forall {a} {a} {a} {b}. a -> Message a (Either (Either a a) b)
toMenu b
x)    forall a b. (a -> b) -> a -> b
$ XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	High (Left b
x) ->
	  if XEvent -> Bool
mouse XEvent
ev
	  then forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {a} {a} {a}. a -> Message a (Either a a)
out b
x forall a. a -> [a] -> [a]
: forall {b}. [Message FRequest b]
popdown) forall a b. (a -> b) -> a -> b
$ K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
	  else forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK  (forall {a} {a} {a}. a -> Message a (Either a a)
out b
x)           forall a b. (a -> b) -> a -> b
$ XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	Low (XEvt (KeyEvent {type' :: XEvent -> Pressed
type'=Pressed
Released, keySym :: XEvent -> String
keySym=String
ks})) ->
	  if XEvent -> String -> Bool
samekey XEvent
ev String
ks
	  then forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK forall {b}. [Message FRequest b]
popdown K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
downK
	  else XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev
	KEvent (Either b (Either PopupMenu b))
_ -> XEvent
-> K (Either b (Either PopupMenu b)) (Either (Either Bool b) b)
upK XEvent
ev

{- handleButtonMachineF fud records the paths of all button machines in fud, so
   that a message can be broadcast to them when the MenuPopup mode changes.
   It also keeps track of the current mode to avoid sending the same mode twice.
-}

handleButtonMachinesF :: F b d -> F (Either Bool b) d
handleButtonMachinesF F b d
fud =
    forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF forall {b} {b}.
F (Either (Either Path b) (Either Bool b))
  (Either (Either (Path, Bool) b) b)
ctrlF (forall {b} {b}. F b b -> F (Either (Path, Bool) b) (Either Path b)
liftbm F b d
fud)
  where
    ctrlF :: F (Either (Either Path b) (Either Bool b))
  (Either (Either (Path, Bool) b) b)
ctrlF = forall {t} {a} {b}. (t -> a -> (t, [b])) -> t -> F a b
mapstateF forall {a} {a} {b} {b}.
(Eq a, Eq a) =>
(a, [a])
-> Either (Either a b) (Either a b)
-> ((a, [a]), [Either (Either (a, a) b) b])
ctrl (Bool
False,[])

    ctrl :: (a, [a])
-> Either (Either a b) (Either a b)
-> ((a, [a]), [Either (Either (a, a) b) b])
ctrl state :: (a, [a])
state@(a
mode,[a]
bms) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {b} {b}.
Either a b -> ((a, [a]), [Either (Either (a, a) b) b])
fromLoop forall {b} {b}.
Either a b -> ((a, [a]), [Either (Either (a, a) b) b])
fromOutside
      where
	fromLoop :: Either a b -> ((a, [a]), [Either (Either (a, a) b) b])
fromLoop (Left a
path) = forall {b} {b}. a -> ((a, [a]), [Either (Either (a, a) b) b])
addbm a
path
	fromLoop (Right b
y) = forall {b} {a}. b -> ((a, [a]), [Either a b])
out b
y

        fromOutside :: Either a b -> ((a, [a]), [Either (Either (a, a) b) b])
fromOutside (Left a
mode') = forall {b} {b}. a -> ((a, [a]), [Either (Either (a, a) b) b])
changeMode a
mode'
	fromOutside (Right b
x) = forall {b} {a} {b}. b -> ((a, [a]), [Either (Either a b) b])
inp b
x

        addbm :: a -> ((a, [a]), [Either (Either (a, a) b) b])
addbm a
path = ((a
mode,[a
path] forall a. Eq a => [a] -> [a] -> [a]
`union` [a]
bms),[forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left (a
path,a
mode))])
	  -- Tell the new button the current mode. (Needed in case it is
	  -- dynamically created inside a menu.)
        out :: b -> ((a, [a]), [Either a b])
out b
y = ((a, [a])
state,[forall a b. b -> Either a b
Right b
y])
	inp :: b -> ((a, [a]), [Either (Either a b) b])
inp b
x = ((a, [a])
state,[forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right b
x)])

	changeMode :: a -> ((a, [a]), [Either (Either (a, a) b) b])
changeMode a
mode' =
	  if a
mode'forall a. Eq a => a -> a -> Bool
/=a
mode
	  then ((a
mode',[a]
bms),[forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left (a
path,a
mode')) | a
path<-[a]
bms])
	      -- !! This will send msgs also to buttons that have been destroyed
	  else ((a, [a])
state,[])

    liftbm :: F b b -> F (Either (Path, Bool) b) (Either Path b)
liftbm (F FSP b b
sp) = forall hi ho. FSP hi ho -> F hi ho
F forall a b. (a -> b) -> a -> b
$ forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP forall {a} {b}.
Message (a, FResponse) (Either (a, Bool) b)
-> Message (a, FResponse) b
pre forall {a} {b}.
Message (a, FRequest) b -> Message (a, FRequest) (Either a b)
post FSP b b
sp
      where
	pre :: Message (a, FResponse) (Either (a, Bool) b)
-> Message (a, FResponse) b
pre (High (Left (a
path,Bool
mode))) = forall a b. a -> Message a b
Low (a
path,XEvent -> FResponse
XEvt (Bool -> XEvent
MenuPopupMode Bool
mode))
	pre (High (Right b
x)) = forall a b. b -> Message a b
High b
x
	pre (Low (a, FResponse)
tevent) = forall a b. a -> Message a b
Low (a, FResponse)
tevent

	post :: Message (a, FRequest) b -> Message (a, FRequest) (Either a b)
post (Low (a
path,XCmd XCommand
MeButtonMachine)) = forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left a
path)
	post (Low (a, FRequest)
tcmd) = forall a b. a -> Message a b
Low (a, FRequest)
tcmd
	post (High b
y) = forall a b. b -> Message a b
High (forall a b. b -> Either a b
Right b
y)