module SuperMenuF (superMenuF, MenuItem (..)) where
--module SuperMenuF where
import AllFudgets
import Data.Maybe(fromJust) --,fromMaybe
import HbcUtils(breakAt)

data MenuItem a =
       Item a
       | Submenu (String, [MenuItem a])
       deriving (MenuItem a -> MenuItem a -> Bool
(MenuItem a -> MenuItem a -> Bool)
-> (MenuItem a -> MenuItem a -> Bool) -> Eq (MenuItem a)
forall a. Eq a => MenuItem a -> MenuItem a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MenuItem a -> MenuItem a -> Bool
$c/= :: forall a. Eq a => MenuItem a -> MenuItem a -> Bool
== :: MenuItem a -> MenuItem a -> Bool
$c== :: forall a. Eq a => MenuItem a -> MenuItem a -> Bool
Eq, Eq (MenuItem a)
Eq (MenuItem a)
-> (MenuItem a -> MenuItem a -> Ordering)
-> (MenuItem a -> MenuItem a -> Bool)
-> (MenuItem a -> MenuItem a -> Bool)
-> (MenuItem a -> MenuItem a -> Bool)
-> (MenuItem a -> MenuItem a -> Bool)
-> (MenuItem a -> MenuItem a -> MenuItem a)
-> (MenuItem a -> MenuItem a -> MenuItem a)
-> Ord (MenuItem a)
MenuItem a -> MenuItem a -> Bool
MenuItem a -> MenuItem a -> Ordering
MenuItem a -> MenuItem a -> MenuItem a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (MenuItem a)
forall a. Ord a => MenuItem a -> MenuItem a -> Bool
forall a. Ord a => MenuItem a -> MenuItem a -> Ordering
forall a. Ord a => MenuItem a -> MenuItem a -> MenuItem a
min :: MenuItem a -> MenuItem a -> MenuItem a
$cmin :: forall a. Ord a => MenuItem a -> MenuItem a -> MenuItem a
max :: MenuItem a -> MenuItem a -> MenuItem a
$cmax :: forall a. Ord a => MenuItem a -> MenuItem a -> MenuItem a
>= :: MenuItem a -> MenuItem a -> Bool
$c>= :: forall a. Ord a => MenuItem a -> MenuItem a -> Bool
> :: MenuItem a -> MenuItem a -> Bool
$c> :: forall a. Ord a => MenuItem a -> MenuItem a -> Bool
<= :: MenuItem a -> MenuItem a -> Bool
$c<= :: forall a. Ord a => MenuItem a -> MenuItem a -> Bool
< :: MenuItem a -> MenuItem a -> Bool
$c< :: forall a. Ord a => MenuItem a -> MenuItem a -> Bool
compare :: MenuItem a -> MenuItem a -> Ordering
$ccompare :: forall a. Ord a => MenuItem a -> MenuItem a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (MenuItem a)
Ord, Int -> MenuItem a -> ShowS
[MenuItem a] -> ShowS
MenuItem a -> String
(Int -> MenuItem a -> ShowS)
-> (MenuItem a -> String)
-> ([MenuItem a] -> ShowS)
-> Show (MenuItem a)
forall a. Show a => Int -> MenuItem a -> ShowS
forall a. Show a => [MenuItem a] -> ShowS
forall a. Show a => MenuItem a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MenuItem a] -> ShowS
$cshowList :: forall a. Show a => [MenuItem a] -> ShowS
show :: MenuItem a -> String
$cshow :: forall a. Show a => MenuItem a -> String
showsPrec :: Int -> MenuItem a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MenuItem a -> ShowS
Show)

data MenuTag a =
       ItemTag a
       | SubTag String
       deriving (MenuTag a -> MenuTag a -> Bool
(MenuTag a -> MenuTag a -> Bool)
-> (MenuTag a -> MenuTag a -> Bool) -> Eq (MenuTag a)
forall a. Eq a => MenuTag a -> MenuTag a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MenuTag a -> MenuTag a -> Bool
$c/= :: forall a. Eq a => MenuTag a -> MenuTag a -> Bool
== :: MenuTag a -> MenuTag a -> Bool
$c== :: forall a. Eq a => MenuTag a -> MenuTag a -> Bool
Eq, Eq (MenuTag a)
Eq (MenuTag a)
-> (MenuTag a -> MenuTag a -> Ordering)
-> (MenuTag a -> MenuTag a -> Bool)
-> (MenuTag a -> MenuTag a -> Bool)
-> (MenuTag a -> MenuTag a -> Bool)
-> (MenuTag a -> MenuTag a -> Bool)
-> (MenuTag a -> MenuTag a -> MenuTag a)
-> (MenuTag a -> MenuTag a -> MenuTag a)
-> Ord (MenuTag a)
MenuTag a -> MenuTag a -> Bool
MenuTag a -> MenuTag a -> Ordering
MenuTag a -> MenuTag a -> MenuTag a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (MenuTag a)
forall a. Ord a => MenuTag a -> MenuTag a -> Bool
forall a. Ord a => MenuTag a -> MenuTag a -> Ordering
forall a. Ord a => MenuTag a -> MenuTag a -> MenuTag a
min :: MenuTag a -> MenuTag a -> MenuTag a
$cmin :: forall a. Ord a => MenuTag a -> MenuTag a -> MenuTag a
max :: MenuTag a -> MenuTag a -> MenuTag a
$cmax :: forall a. Ord a => MenuTag a -> MenuTag a -> MenuTag a
>= :: MenuTag a -> MenuTag a -> Bool
$c>= :: forall a. Ord a => MenuTag a -> MenuTag a -> Bool
> :: MenuTag a -> MenuTag a -> Bool
$c> :: forall a. Ord a => MenuTag a -> MenuTag a -> Bool
<= :: MenuTag a -> MenuTag a -> Bool
$c<= :: forall a. Ord a => MenuTag a -> MenuTag a -> Bool
< :: MenuTag a -> MenuTag a -> Bool
$c< :: forall a. Ord a => MenuTag a -> MenuTag a -> Bool
compare :: MenuTag a -> MenuTag a -> Ordering
$ccompare :: forall a. Ord a => MenuTag a -> MenuTag a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (MenuTag a)
Ord)

data PopupSubMenu =
       PopupSub Point
       | PopdownSub
          
mainTag :: MenuTag a
mainTag = String -> MenuTag a
forall a. String -> MenuTag a
SubTag String
"Joost Bossuyt"

modstate :: [a]
modstate = []

mousebutton :: Button
mousebutton = Int -> Button
Button Int
1

menuButtonF1 :: (GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F a (BMevents, Maybe Point)
menuButtonF1 (GCId, GCId, FontStruct)
gcs Maybe Rect
optrect String
text =
  let mask :: [EventMask]
mask =
        [EventMask
EnterWindowMask, EventMask
LeaveWindowMask, EventMask
ButtonPressMask, EventMask
ButtonReleaseMask,
         EventMask
ExposureMask]
      startcmds :: [FRequest]
startcmds =
        [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
mask, BackingStore -> WindowAttributes
CWBackingStore BackingStore
Always]]
      optsize :: Maybe Point
optsize = (Rect -> Point) -> Maybe Rect -> Maybe Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rect -> Point
rectsize Maybe Rect
optrect
  in [FRequest]
-> Maybe Rect
-> K a (BMevents, Maybe Point)
-> F a (BMevents, Maybe Point)
forall a ho. [FRequest] -> Maybe Rect -> K a ho -> F a ho
swindowF [FRequest]
startcmds
             Maybe Rect
optrect
             ((GCId, GCId, FontStruct)
-> Maybe Point -> String -> K a (BMevents, Maybe Point)
forall a.
(GCId, GCId, FontStruct)
-> Maybe Point -> String -> K a (BMevents, Maybe Point)
buttonDisplayK (GCId, GCId, FontStruct)
gcs Maybe Point
optsize String
text)

lxcmd :: XCommand -> Message FRequest b
lxcmd = FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (FRequest -> Message FRequest b)
-> (XCommand -> FRequest) -> XCommand -> Message FRequest b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd

buttonDisplayK :: (GCId, GCId, FontStruct)
-> Maybe Point -> String -> K a (BMevents, Maybe Point)
buttonDisplayK (GCId
drawGC,GCId
invertGC,FontStruct
fs) Maybe Point
opsize String
text =
    let Rect Point
spos Point
ssize = FontStruct -> String -> Rect
string_rect FontStruct
fs String
text
        margin :: Point
margin = Int -> Int -> Point
Point Int
3 Int
1
        size :: Point
size =case Maybe Point
opsize of
                Just s -> Point
s
                Maybe Point
Nothing -> Point -> Point -> Point
padd Point
ssize (Point -> Point -> Point
padd Point
margin Point
margin)
        invertitif :: Bool -> Point -> [Message FRequest b]
invertitif Bool
b Point
size' =
          if Bool
b then [FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (GCId -> Rect -> FRequest
wFillRectangle GCId
invertGC (Point -> Point -> Rect
Rect Point
origin Point
size'))]
               else []
        drawit :: BMevents -> Point -> [Message FRequest b]
drawit BMevents
state Point
size' =
          let textpos :: Point
textpos = Point -> Point -> Point
psub Point
margin Point
spos
          in [XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd XCommand
ClearWindow, FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (GCId -> Point -> String -> FRequest
wDrawImageString GCId
drawGC Point
textpos String
text)]
                [Message FRequest b]
-> [Message FRequest b] -> [Message FRequest b]
forall a. [a] -> [a] -> [a]
++ Bool -> Point -> [Message FRequest b]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
state BMevents -> BMevents -> Bool
forall a. Eq a => a -> a -> Bool
== BMevents
BMInverted) Point
size'
        buttonproc :: BMevents -> Point -> K a (BMevents, Maybe Point)
buttonproc BMevents
bstate Point
size' =
          let same :: K a (BMevents, Maybe Point)
same = BMevents -> Point -> K a (BMevents, Maybe Point)
buttonproc BMevents
bstate Point
size'
              cont :: BMevents -> K a (BMevents, Maybe Point)
cont BMevents
b = BMevents -> Point -> K a (BMevents, Maybe Point)
buttonproc BMevents
b Point
size'
              redraw :: BMevents -> Point -> K a (BMevents, Maybe Point)
redraw BMevents
b Point
s = [KCommand (BMevents, Maybe Point)]
-> K a (BMevents, Maybe Point) -> K a (BMevents, Maybe Point)
forall b a. [KCommand b] -> K a b -> K a b
putsK (BMevents -> Point -> [KCommand (BMevents, Maybe Point)]
forall b. BMevents -> Point -> [Message FRequest b]
drawit BMevents
b Point
s) (BMevents -> Point -> K a (BMevents, Maybe Point)
buttonproc BMevents
b Point
s)
          in Cont (K a (BMevents, Maybe Point)) (KEvent a)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K a (BMevents, Maybe Point)) (KEvent a)
-> Cont (K a (BMevents, Maybe Point)) (KEvent a)
forall a b. (a -> b) -> a -> b
$ \KEvent a
bmsg ->
               case KEvent a
bmsg of
                 Low (XEvt (Expose Rect
_ Int
0)) -> BMevents -> Point -> K a (BMevents, Maybe Point)
redraw BMevents
bstate Point
size'
                 Low (LEvt (LayoutSize Point
size'')) -> BMevents -> Point -> K a (BMevents, Maybe Point)
redraw BMevents
bstate Point
size''
                 Low (XEvt (ButtonEvent Int
_ Point
_ Point
_ ModState
_ Pressed
Released Button
_)) ->
                   [KCommand (BMevents, Maybe Point)]
-> K a (BMevents, Maybe Point) -> K a (BMevents, Maybe Point)
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand (BMevents, Maybe Point)]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate BMevents -> BMevents -> Bool
forall a. Eq a => a -> a -> Bool
== BMevents
BMInverted) Point
size'
                           [KCommand (BMevents, Maybe Point)]
-> [KCommand (BMevents, Maybe Point)]
-> [KCommand (BMevents, Maybe Point)]
forall a. [a] -> [a] -> [a]
++ [(BMevents, Maybe Point) -> KCommand (BMevents, Maybe Point)
forall a b. b -> Message a b
High (BMevents
BMClick, Maybe Point
forall a. Maybe a
Nothing)])
                        (BMevents -> K a (BMevents, Maybe Point)
cont BMevents
BMNormal)
                 Low (XEvt (EnterNotify {pos :: XEvent -> Point
pos=Point
winpos,rootPos :: XEvent -> Point
rootPos=Point
rootpos})) ->
                   let width :: Point
width = Int -> Int -> Point
Point (Point -> Int
xcoord Point
size') (-Int
1) 
                       pos :: Point
pos = Point -> Point -> Point
padd (Point -> Point -> Point
psub Point
rootpos Point
winpos) Point
width
                   in [KCommand (BMevents, Maybe Point)]
-> K a (BMevents, Maybe Point) -> K a (BMevents, Maybe Point)
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand (BMevents, Maybe Point)]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate BMevents -> BMevents -> Bool
forall a. Eq a => a -> a -> Bool
/= BMevents
BMInverted) Point
size'
                              [KCommand (BMevents, Maybe Point)]
-> [KCommand (BMevents, Maybe Point)]
-> [KCommand (BMevents, Maybe Point)]
forall a. [a] -> [a] -> [a]
++ [(BMevents, Maybe Point) -> KCommand (BMevents, Maybe Point)
forall a b. b -> Message a b
High (BMevents
BMInverted, Point -> Maybe Point
forall a. a -> Maybe a
Just Point
pos)])
                        (BMevents -> K a (BMevents, Maybe Point)
cont BMevents
BMInverted)
                 Low (XEvt (LeaveNotify {})) ->
                   [KCommand (BMevents, Maybe Point)]
-> K a (BMevents, Maybe Point) -> K a (BMevents, Maybe Point)
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand (BMevents, Maybe Point)]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate BMevents -> BMevents -> Bool
forall a. Eq a => a -> a -> Bool
/= BMevents
BMNormal) Point
size') (BMevents -> K a (BMevents, Maybe Point)
cont BMevents
BMNormal)
                 KEvent a
_ -> K a (BMevents, Maybe Point)
same
    in [KCommand (BMevents, Maybe Point)]
-> K a (BMevents, Maybe Point) -> K a (BMevents, Maybe Point)
forall b a. [KCommand b] -> K a b -> K a b
putsK [FRequest -> KCommand (BMevents, Maybe Point)
forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size Bool
True Bool
True))]
            (BMevents -> Point -> K a (BMevents, Maybe Point)
forall a. BMevents -> Point -> K a (BMevents, Maybe Point)
buttonproc BMevents
BMNormal Point
size)

menuListF :: (GCId, GCId, FontStruct)
-> [MenuTag t]
-> (t -> String)
-> F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
menuListF (GCId, GCId, FontStruct)
gcs [MenuTag t]
alts t -> String
show_alt =
  let --show_MenuTag :: MenuTag a -> String
      show_MenuTag :: MenuTag t -> String
show_MenuTag MenuTag t
x =
        case MenuTag t
x of
          ItemTag t
a -> t -> String
show_alt t
a
          SubTag String
s -> String
s
      altButton :: MenuTag t -> (MenuTag t, F a (BMevents, Maybe Point))
altButton MenuTag t
alt = (MenuTag t
alt, (GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F a (BMevents, Maybe Point)
forall a.
(GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F a (BMevents, Maybe Point)
menuButtonF1 (GCId, GCId, FontStruct)
gcs Maybe Rect
forall a. Maybe a
Nothing (MenuTag t -> String
show_MenuTag MenuTag t
alt))
  in Placer
-> [(MenuTag t, F b (BMevents, Maybe Point))]
-> F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
forall a b c. Eq a => Placer -> [(a, F b c)] -> F (a, b) (a, c)
listLF (Int -> Placer
verticalP' Int
0) ((MenuTag t -> (MenuTag t, F b (BMevents, Maybe Point)))
-> [MenuTag t] -> [(MenuTag t, F b (BMevents, Maybe Point))]
forall a b. (a -> b) -> [a] -> [b]
map MenuTag t -> (MenuTag t, F b (BMevents, Maybe Point))
forall a. MenuTag t -> (MenuTag t, F a (BMevents, Maybe Point))
altButton [MenuTag t]
alts)

subMenuF :: (GCId, GCId, FontStruct)
-> p
-> [MenuTag t]
-> (t -> String)
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
subMenuF (GCId, GCId, FontStruct)
gcs p
optrect [MenuTag t]
alts t -> String
show_alt =
    let wattrs :: [WindowAttributes]
wattrs = [[EventMask] -> WindowAttributes
CWEventMask [], Bool -> WindowAttributes
CWSaveUnder Bool
True, Bool -> WindowAttributes
CWOverrideRedirect Bool
True]
        startcmds :: [Message FRequest b]
startcmds = [XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd (XCommand -> Message FRequest b) -> XCommand -> Message FRequest b
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs,
	             XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd (XCommand -> Message FRequest b) -> XCommand -> Message FRequest b
forall a b. (a -> b) -> a -> b
$ [WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
1]]
        fudget :: F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
fudget = (GCId, GCId, FontStruct)
-> [MenuTag t]
-> (t -> String)
-> F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
forall t b.
Eq t =>
(GCId, GCId, FontStruct)
-> [MenuTag t]
-> (t -> String)
-> F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
menuListF (GCId, GCId, FontStruct)
gcs [MenuTag t]
alts t -> String
show_alt 
    in F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
forall hi ho. F hi ho -> F hi ho
delayF (F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
 -> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point)))
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
forall a b. (a -> b) -> a -> b
$
       F (Either
     (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
     (MenuTag t, Any))
  (Either
     (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
     (MenuTag t, (BMevents, Maybe Point)))
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (F (Either
      (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
      (MenuTag t, Any))
   (Either
      (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
      (MenuTag t, (BMevents, Maybe Point)))
 -> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point)))
-> F (Either
        (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
        (MenuTag t, Any))
     (Either
        (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
        (MenuTag t, (BMevents, Maybe Point)))
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
forall a b. (a -> b) -> a -> b
$
       Customiser ShellF
-> K (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
     (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
-> F (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point))
-> F (Either
        (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
        (MenuTag t, Any))
     (Either
        (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
        (MenuTag t, (BMevents, Maybe Point)))
forall a b c d.
Customiser ShellF -> K a b -> F c d -> F (Either a c) (Either b d)
shellKF' (Int -> Customiser ShellF
forall xxx. HasMargin xxx => Int -> Customiser xxx
setMargin Int
0Customiser ShellF -> Customiser ShellF -> Customiser ShellF
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Bool -> Customiser ShellF
forall xxx. HasVisible xxx => Bool -> Customiser xxx
setVisible Bool
False) ([KCommand
   (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))]
-> K (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
     (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
-> K (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
     (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
forall b a. [KCommand b] -> K a b -> K a b
putsK [KCommand
   (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))]
forall b. [Message FRequest b]
startcmds K (Either (MenuTag t, (BMevents, Maybe Point)) PopupSubMenu)
  (Either (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point)))
forall a a b a.
K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
subMenuK) F (MenuTag t, Any) (MenuTag t, (BMevents, Maybe Point))
forall b. F (MenuTag t, b) (MenuTag t, (BMevents, Maybe Point))
fudget

subMenuK :: K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
subMenuK =
  let popdown :: [Message FRequest b]
popdown = (XCommand -> Message FRequest b)
-> [XCommand] -> [Message FRequest b]
forall a b. (a -> b) -> [a] -> [b]
map XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd [XCommand
UnmapWindow]
      popup :: Point -> [Message FRequest b]
popup Point
p = (XCommand -> Message FRequest b)
-> [XCommand] -> [Message FRequest b]
forall a b. (a -> b) -> [a] -> [b]
map XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd [Point -> XCommand
moveWindow Point
p, XCommand
MapRaised]
      downK :: K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
downK =
        Cont
  (K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b))))
  (KEvent (Either (a, (a, b)) PopupSubMenu))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK (\KEvent (Either (a, (a, b)) PopupSubMenu)
msg ->
          case KEvent (Either (a, (a, b)) PopupSubMenu)
msg of
            High (Right (PopupSub Point
p )) -> [KCommand (Either a (a, (a, b)))]
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
forall b a. [KCommand b] -> K a b -> K a b
putsK (Point -> [KCommand (Either a (a, (a, b)))]
forall b. Point -> [Message FRequest b]
popup Point
p) K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
upK
            KEvent (Either (a, (a, b)) PopupSubMenu)
_ -> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
downK)
      upK :: K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
upK =
        Cont
  (K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b))))
  (KEvent (Either (a, (a, b)) PopupSubMenu))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK (\KEvent (Either (a, (a, b)) PopupSubMenu)
msg ->
          case KEvent (Either (a, (a, b)) PopupSubMenu)
msg of
            High (Right PopupSubMenu
PopdownSub) -> [KCommand (Either a (a, (a, b)))]
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
forall b a. [KCommand b] -> K a b -> K a b
putsK [KCommand (Either a (a, (a, b)))]
forall b. [Message FRequest b]
popdown K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
downK
            High (Left (a
alt, (a
bm, b
pos))) ->
              [KCommand (Either a (a, (a, b)))]
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
forall b a. [KCommand b] -> K a b -> K a b
putsK [Either a (a, (a, b)) -> KCommand (Either a (a, (a, b)))
forall a b. b -> Message a b
High ((a, (a, b)) -> Either a (a, (a, b))
forall a b. b -> Either a b
Right (a
alt, (a
bm, b
pos)))] K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
upK
            KEvent (Either (a, (a, b)) PopupSubMenu)
_ -> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
upK)
  in Int
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
-> K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
forall a b. Int -> K a b -> K a b
setFontCursor Int
110 K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
forall a a b a.
K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
downK

controlF :: [(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
-> F PopupSubMenu d
controlF [(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
list = F (Either
     (Either
        (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
     (MenuTag d, PopupSubMenu))
  (Either
     (Either (MenuTag d, PopupSubMenu) d)
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point))))
-> F PopupSubMenu d
forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (K (Either
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag d, PopupSubMenu) d)
-> F (Either
        (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag d, PopupSubMenu) d)
forall a b. K a b -> F a b
kernelF K (Either
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag d, PopupSubMenu) d)
forall a.
Eq a =>
K (Either
     (MenuTag a, (MenuTag a, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag a, PopupSubMenu) a)
controlK F (Either
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag d, PopupSubMenu) d)
-> F (MenuTag d, PopupSubMenu)
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point)))
-> F (Either
        (Either
           (MenuTag d, (MenuTag d, (BMevents, Maybe Point))) PopupSubMenu)
        (MenuTag d, PopupSubMenu))
     (Either
        (Either (MenuTag d, PopupSubMenu) d)
        (MenuTag d, (MenuTag d, (BMevents, Maybe Point))))
forall a b c d. F a b -> F c d -> F (Either a c) (Either b d)
>+< [(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
-> F (MenuTag d, PopupSubMenu)
     (MenuTag d, (MenuTag d, (BMevents, Maybe Point)))
forall a b c. Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF [(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
list)

controlK ::
  (Eq a) =>K (Either (MenuTag a,(MenuTag a,(BMevents,Maybe Point))) PopupSubMenu)
             (Either (MenuTag a,PopupSubMenu) a)
controlK :: K (Either
     (MenuTag a, (MenuTag a, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag a, PopupSubMenu) a)
controlK =
  let proc :: [MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
active =
        Cont
  (K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b))
  (KEvent
     (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK (\KEvent
  (Either
     (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
msg ->
          case KEvent
  (Either
     (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
msg of
            High (Left (MenuTag a
tag, (SubTag String
s, (BMevents
bm, Maybe Point
opoint)))) ->
              (case BMevents
bm of
                 BMevents
BMClick ->
                   let oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = (MenuTag a -> Message a (Either (MenuTag a, PopupSubMenu) b))
-> [MenuTag a] -> [Message a (Either (MenuTag a, PopupSubMenu) b)]
forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> Either (MenuTag a, PopupSubMenu) b
-> Message a (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
                   in [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK [KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a b. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [])
                 BMevents
BMInverted ->
                   let ([MenuTag a]
olist, [MenuTag a]
nlist) = MenuTag a -> [MenuTag a] -> ([MenuTag a], [MenuTag a])
forall a. Eq a => a -> [a] -> ([a], [a])
breakAt MenuTag a
tag [MenuTag a]
active
                       newlist :: [MenuTag a]
newlist = [String -> MenuTag a
forall a. String -> MenuTag a
SubTag String
s, MenuTag a
tag] [MenuTag a] -> [MenuTag a] -> [MenuTag a]
forall a. [a] -> [a] -> [a]
++ [MenuTag a]
nlist
                       oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = (MenuTag a -> Message a (Either (MenuTag a, PopupSubMenu) b))
-> [MenuTag a] -> [Message a (Either (MenuTag a, PopupSubMenu) b)]
forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> Either (MenuTag a, PopupSubMenu) b
-> Message a (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
olist
                       pos :: Point
pos = Maybe Point -> Point
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Point
opoint
                   in [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK ([KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a b. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> [KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a. [a] -> [a] -> [a]
++ [Either (MenuTag a, PopupSubMenu) b
-> KCommand (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left(String -> MenuTag a
forall a. String -> MenuTag a
SubTag String
s, Point -> PopupSubMenu
PopupSub Point
pos))])
                           ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
newlist)
                 BMevents
_ -> [MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
active)
            High (Left (MenuTag a
tag, (ItemTag b
a, (BMevents
bm, Maybe Point
opoint)))) ->
              (case BMevents
bm of
                 BMevents
BMClick ->
                   let oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = (MenuTag a -> Message a (Either (MenuTag a, PopupSubMenu) b))
-> [MenuTag a] -> [Message a (Either (MenuTag a, PopupSubMenu) b)]
forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> Either (MenuTag a, PopupSubMenu) b
-> Message a (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
                   in [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK ([KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a b. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> [KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a. [a] -> [a] -> [a]
++ [Either (MenuTag a, PopupSubMenu) b
-> KCommand (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High (b -> Either (MenuTag a, PopupSubMenu) b
forall a b. b -> Either a b
Right b
a)]) ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [])
                 BMevents
BMInverted ->
                   let ([MenuTag a]
olist, [MenuTag a]
nlist) = MenuTag a -> [MenuTag a] -> ([MenuTag a], [MenuTag a])
forall a. Eq a => a -> [a] -> ([a], [a])
breakAt MenuTag a
tag [MenuTag a]
active
                       newlist :: [MenuTag a]
newlist = [MenuTag a
tag] [MenuTag a] -> [MenuTag a] -> [MenuTag a]
forall a. [a] -> [a] -> [a]
++ [MenuTag a]
nlist
                       oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = (MenuTag a -> Message a (Either (MenuTag a, PopupSubMenu) b))
-> [MenuTag a] -> [Message a (Either (MenuTag a, PopupSubMenu) b)]
forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> Either (MenuTag a, PopupSubMenu) b
-> Message a (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
olist
                   in [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK [KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a b. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
newlist)
                 BMevents
_ -> [MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
active)
            High (Right (PopupSub Point
pos)) ->
              [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK [Either (MenuTag a, PopupSubMenu) b
-> KCommand (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
forall a. MenuTag a
mainTag, Point -> PopupSubMenu
PopupSub Point
pos))] ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a
forall a. MenuTag a
mainTag])
            High (Right PopupSubMenu
PopdownSub) ->
              let oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = (MenuTag a -> Message a (Either (MenuTag a, PopupSubMenu) b))
-> [MenuTag a] -> [Message a (Either (MenuTag a, PopupSubMenu) b)]
forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> Either (MenuTag a, PopupSubMenu) b
-> Message a (Either (MenuTag a, PopupSubMenu) b)
forall a b. b -> Message a b
High ((MenuTag a, PopupSubMenu) -> Either (MenuTag a, PopupSubMenu) b
forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
              in [KCommand (Either (MenuTag a, PopupSubMenu) b)]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
forall b a. [KCommand b] -> K a b -> K a b
putsK [KCommand (Either (MenuTag a, PopupSubMenu) b)]
forall a b. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist ([MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [])
            KEvent
  (Either
     (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
_ -> [MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc [MenuTag a]
active)
  in [MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag a, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) a)
forall a b.
Eq a =>
[MenuTag a]
-> K (Either
        (MenuTag a, (MenuTag b, (BMevents, Maybe Point))) PopupSubMenu)
     (Either (MenuTag a, PopupSubMenu) b)
proc []

clickF1 :: (GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F String PopupSubMenu
clickF1 (GCId, GCId, FontStruct)
gcs Maybe Rect
optrect String
name =
  let topopup :: a -> Message a (Either a b)
topopup = Either a b -> Message a (Either a b)
forall a b. b -> Message a b
High (Either a b -> Message a (Either a b))
-> (a -> Either a b) -> a -> Message a (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
      routeClick :: a -> Either a b
routeClick = a -> Either a b
forall a b. a -> Either a b
Left
      optsize :: Maybe Point
optsize = (Rect -> Point) -> Maybe Rect -> Maybe Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rect -> Point
rectsize Maybe Rect
optrect
      proc :: Message FResponse b
-> Message FResponse (Either (Bool, PopupSubMenu) b)
proc (Low (XEvt (ButtonEvent Int
_ Point
winpos Point
rootpos [] Pressed
Pressed (Button Int
1)))) =
          (Bool, PopupSubMenu)
-> Message FResponse (Either (Bool, PopupSubMenu) b)
forall a a b. a -> Message a (Either a b)
topopup (Bool
True, Point -> PopupSubMenu
PopupSub (Point -> Point -> Point
psub Point
rootpos Point
winpos))
      proc (Low (XEvt (ButtonEvent Int
_ Point
_ Point
_ ModState
_ Pressed
Released (Button Int
1)))) =
          (Bool, PopupSubMenu)
-> Message FResponse (Either (Bool, PopupSubMenu) b)
forall a a b. a -> Message a (Either a b)
topopup (Bool
False, PopupSubMenu
PopdownSub)
      proc (Low (XEvt (LeaveNotify {mode :: XEvent -> Mode
mode=Mode
NotifyUngrab}))) =
          (Bool, PopupSubMenu)
-> Message FResponse (Either (Bool, PopupSubMenu) b)
forall a a b. a -> Message a (Either a b)
topopup (Bool
False, PopupSubMenu
PopdownSub)
      proc (Low FResponse
msg) = FResponse -> Message FResponse (Either (Bool, PopupSubMenu) b)
forall a b. a -> Message a b
Low FResponse
msg
      proc (High b
hi) = Either (Bool, PopupSubMenu) b
-> Message FResponse (Either (Bool, PopupSubMenu) b)
forall a b. b -> Message a b
High (b -> Either (Bool, PopupSubMenu) b
forall a b. b -> Either a b
Right b
hi)
      wattrs :: [WindowAttributes]
wattrs =
        [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask, EventMask
ButtonPressMask, EventMask
ButtonReleaseMask,
         EventMask
OwnerGrabButtonMask, EventMask
LeaveWindowMask, EventMask
EnterWindowMask]]
      startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs,
                   XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
1]]
      K KSP (Either (Bool, PopupSubMenu) String) PopupSubMenu
cdisp = (GCId, GCId, FontStruct)
-> Maybe Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
clickDisplayK (GCId, GCId, FontStruct)
gcs Maybe Point
optsize String
name
  in [FRequest]
-> Maybe Rect -> K String PopupSubMenu -> F String PopupSubMenu
forall a ho. [FRequest] -> Maybe Rect -> K a ho -> F a ho
swindowF [FRequest]
startcmds
             Maybe Rect
optrect
             (KSP String PopupSubMenu -> K String PopupSubMenu
forall hi ho. KSP hi ho -> K hi ho
K (KSP String PopupSubMenu -> K String PopupSubMenu)
-> KSP String PopupSubMenu -> K String PopupSubMenu
forall a b. (a -> b) -> a -> b
$ KSP (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> (Message FResponse String
    -> KEvent (Either (Bool, PopupSubMenu) String))
-> KSP String PopupSubMenu
forall a b t. SP a b -> (t -> a) -> SP t b
preMapSP KSP (Either (Bool, PopupSubMenu) String) PopupSubMenu
cdisp  Message FResponse String
-> KEvent (Either (Bool, PopupSubMenu) String)
forall b.
Message FResponse b
-> Message FResponse (Either (Bool, PopupSubMenu) b)
proc)

clickDisplayK :: (GCId, GCId, FontStruct)
-> Maybe Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
clickDisplayK (GCId
drawGC,GCId
invertGC,FontStruct
fs) Maybe Point
optsize String
name0 =
  let Rect Point
spos Point
ssize = FontStruct -> String -> Rect
string_rect FontStruct
fs String
name0
      strsize :: String -> Point
strsize = FontStruct -> String -> Point
string_box_size FontStruct
fs
      margin :: Point
margin = Int -> Int -> Point
Point Int
3 Int
1
      size :: Point
size = Point -> Maybe Point -> Point
forall a. a -> Maybe a -> a
fromMaybe (Point -> Point -> Point
padd Point
ssize (Point -> Point -> Point
padd Point
margin Point
margin)) Maybe Point
optsize
      invertitif :: Bool -> Point -> [Message FRequest b]
invertitif Bool
b Point
size' =
        if Bool
b
          then [FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (GCId -> Rect -> FRequest
wFillRectangle GCId
invertGC (Point -> Point -> Rect
Rect Point
origin Point
size'))]
          else []
      drawname :: String -> Bool -> Point -> [Message FRequest b]
drawname String
name Bool
hi Point
size =
        let textpos :: Point
textpos = Double -> Point -> Point
forall a. RealFrac a => a -> Point -> Point
scalePoint Double
0.5 (Point
size Point -> Point -> Point
`psub` String -> Point
strsize String
name) Point -> Point -> Point
`psub` Point
spos
        in [XCommand -> Message FRequest b
forall b. XCommand -> Message FRequest b
lxcmd XCommand
ClearWindow, FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (GCId -> Point -> String -> FRequest
wDrawImageString GCId
drawGC Point
textpos String
name)]
               [Message FRequest b]
-> [Message FRequest b] -> [Message FRequest b]
forall a. [a] -> [a] -> [a]
++ Bool -> Point -> [Message FRequest b]
forall b. Bool -> Point -> [Message FRequest b]
invertitif Bool
hi Point
size
      buttonproc :: Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
highlighted Point
size' String
name =
        let fixpos :: PopupSubMenu -> PopupSubMenu
fixpos (PopupSub Point
p) =
              Point -> PopupSubMenu
PopupSub (Point
p Point -> Point -> Point
`padd` Int -> Int -> Point
pP (-Int
1) (Point -> Int
ycoord Point
size'))
            fixpos PopupSubMenu
msg = PopupSubMenu
msg
            same :: K (Either (Bool, PopupSubMenu) String) PopupSubMenu
same = Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
highlighted Point
size' String
name
            cont :: Bool -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
cont Bool
b = Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
b Point
size' String
name
            contn :: String -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
contn String
n = Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
highlighted Point
size' String
n
            redraw :: Bool
-> Point -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
redraw Bool
b Point
s = [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK (String -> Bool -> Point -> [KCommand PopupSubMenu]
forall b. String -> Bool -> Point -> [Message FRequest b]
drawname String
name Bool
b Point
s) (Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
b Point
s String
name)
            newname :: String -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
newname String
name' = [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK (String -> Bool -> Point -> [KCommand PopupSubMenu]
forall b. String -> Bool -> Point -> [Message FRequest b]
drawname String
name' Bool
highlighted Point
size')
                                 (String -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
contn String
name')
        in Cont
  (K (Either (Bool, PopupSubMenu) String) PopupSubMenu)
  (KEvent (Either (Bool, PopupSubMenu) String))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont
  (K (Either (Bool, PopupSubMenu) String) PopupSubMenu)
  (KEvent (Either (Bool, PopupSubMenu) String))
-> Cont
     (K (Either (Bool, PopupSubMenu) String) PopupSubMenu)
     (KEvent (Either (Bool, PopupSubMenu) String))
forall a b. (a -> b) -> a -> b
$ \KEvent (Either (Bool, PopupSubMenu) String)
bmsg ->
             case KEvent (Either (Bool, PopupSubMenu) String)
bmsg of
               Low (XEvt (Expose Rect
_ Int
0)) -> Bool
-> Point -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
redraw Bool
highlighted Point
size'
               Low (LEvt (LayoutSize Point
size'')) -> Bool
-> Point -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
redraw Bool
highlighted Point
size''
               Low (XEvt (LeaveNotify {})) ->
                 [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand PopupSubMenu]
forall b. Bool -> Point -> [Message FRequest b]
invertitif Bool
highlighted Point
size') (Bool -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
cont Bool
False)
               Low (XEvt (EnterNotify {})) ->
                 [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand PopupSubMenu]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (Bool -> Bool
not Bool
highlighted) Point
size') (Bool -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
cont Bool
True)
               High (Left (Bool
hi, PopupSubMenu
msg)) ->
                  [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK (Bool -> Point -> [KCommand PopupSubMenu]
forall b. Bool -> Point -> [Message FRequest b]
invertitif (Bool
hi Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
highlighted) Point
size' [KCommand PopupSubMenu]
-> [KCommand PopupSubMenu] -> [KCommand PopupSubMenu]
forall a. [a] -> [a] -> [a]
++
                        [PopupSubMenu -> KCommand PopupSubMenu
forall a b. b -> Message a b
High (PopupSubMenu -> PopupSubMenu
fixpos PopupSubMenu
msg)])
                       (Bool -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
cont Bool
hi)
               High (Right String
name') -> String -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
newname String
name'
               KEvent (Either (Bool, PopupSubMenu) String)
_ -> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
same
  in [KCommand PopupSubMenu]
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
forall b a. [KCommand b] -> K a b -> K a b
putsK [FRequest -> KCommand PopupSubMenu
forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size Bool
True Bool
True))]
          (Bool
-> Point
-> String
-> K (Either (Bool, PopupSubMenu) String) PopupSubMenu
buttonproc Bool
False Point
size String
name0)

superMenuF :: (Eq a) => (Maybe Rect) -> FontName -> String -> [MenuItem a]
                        -> (a -> String) -> F String a
superMenuF :: Maybe Rect
-> String -> String -> [MenuItem a] -> (a -> String) -> F String a
superMenuF Maybe Rect
oplace String
fname String
text [MenuItem a]
alts a -> String
show_alt =
   String -> (FontStruct -> F String a) -> F String a
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (FontStruct -> f b ho) -> f b ho
safeLoadQueryFont String
fname ((FontStruct -> F String a) -> F String a)
-> (FontStruct -> F String a) -> F String a
forall a b. (a -> b) -> a -> b
$ \FontStruct
fs ->
   ColormapId -> String -> Cont (F String a) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
"black" Cont (F String a) Pixel -> Cont (F String a) Pixel
forall a b. (a -> b) -> a -> b
$ \ Pixel
black ->
   ColormapId -> String -> Cont (F String a) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
"white" Cont (F String a) Pixel -> Cont (F String a) Pixel
forall a b. (a -> b) -> a -> b
$ \ Pixel
white ->
   GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> F String a)
-> F String a
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC [GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, FontId -> GCAttributes Pixel FontId
forall a b. b -> GCAttributes a b
GCFont (FontStruct -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs)] ((GCId -> F String a) -> F String a)
-> (GCId -> F String a) -> F String a
forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
   GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> F String a)
-> F String a
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
drawGC (Pixel -> Pixel -> [GCAttributes Pixel FontId]
forall b. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
black Pixel
white) ((GCId -> F String a) -> F String a)
-> (GCId -> F String a) -> F String a
forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
   let gcs :: (GCId, GCId, FontStruct)
gcs = (GCId
drawGC,GCId
invertGC,FontStruct
fs)
       parse :: MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
parse MenuTag a
tag [MenuItem a]
source [MenuTag a]
current [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done =
        if [MenuItem a]
source [MenuItem a] -> [MenuItem a] -> Bool
forall a. Eq a => a -> a -> Bool
== []
          then if [MenuTag a]
current [MenuTag a] -> [MenuTag a] -> Bool
forall a. Eq a => a -> a -> Bool
== []
                 then [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done
                 else [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
forall a. [a] -> [a] -> [a]
++ [(MenuTag a
tag, (GCId, GCId, FontStruct)
-> Maybe Any
-> [MenuTag a]
-> (a -> String)
-> F PopupSubMenu (MenuTag a, (BMevents, Maybe Point))
forall t p.
Eq t =>
(GCId, GCId, FontStruct)
-> p
-> [MenuTag t]
-> (t -> String)
-> F PopupSubMenu (MenuTag t, (BMevents, Maybe Point))
subMenuF (GCId, GCId, FontStruct)
gcs Maybe Any
forall a. Maybe a
Nothing [MenuTag a]
current a -> String
show_alt)]
          else let (MenuItem a
x : [MenuItem a]
xs) = [MenuItem a]
source
               in case MenuItem a
x of
                    Item a
y -> MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
parse MenuTag a
tag
                                    [MenuItem a]
xs 
                                    ([MenuTag a]
current [MenuTag a] -> [MenuTag a] -> [MenuTag a]
forall a. [a] -> [a] -> [a]
++ [a -> MenuTag a
forall a. a -> MenuTag a
ItemTag a
y])
                                    [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done
                    Submenu (String
s, [MenuItem a]
z) -> MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
parse MenuTag a
tag
                                             [MenuItem a]
xs
                                            ([MenuTag a]
current [MenuTag a] -> [MenuTag a] -> [MenuTag a]
forall a. [a] -> [a] -> [a]
++ [String -> MenuTag a
forall a. String -> MenuTag a
SubTag String
s])
                                            (MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
parse (String -> MenuTag a
forall a. String -> MenuTag a
SubTag String
s) [MenuItem a]
z [] [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done)
   in [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> F PopupSubMenu a
forall d.
Eq d =>
[(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
-> F PopupSubMenu d
controlF (MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
forall a.
MenuTag a
-> [MenuItem a]
-> [MenuTag a]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
-> [(MenuTag a,
     F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
parse MenuTag a
forall a. MenuTag a
mainTag [MenuItem a]
alts [] []) F PopupSubMenu a -> F String PopupSubMenu -> F String a
forall a1 b a2. F a1 b -> F a2 a1 -> F a2 b
>==< (GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F String PopupSubMenu
clickF1 (GCId, GCId, FontStruct)
gcs Maybe Rect
oplace String
text