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
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, MenuItem a -> MenuItem a -> Bool
MenuItem a -> MenuItem a -> Ordering
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
Ord, Int -> MenuItem a -> ShowS
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
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, MenuTag a -> MenuTag a -> Bool
MenuTag a -> MenuTag a -> Ordering
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
Ord)

data PopupSubMenu =
       PopupSub Point
       | PopdownSub
          
mainTag :: MenuTag a
mainTag = 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 hi (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 forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
mask, BackingStore -> WindowAttributes
CWBackingStore BackingStore
Always]]
      optsize :: Maybe Point
optsize = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rect -> Point
rectsize Maybe Rect
optrect
  in forall {hi} {ho}. [FRequest] -> Maybe Rect -> K hi ho -> F hi ho
swindowF [FRequest]
startcmds
             Maybe Rect
optrect
             (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 = forall a b. a -> Message a b
Low 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 Point
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 [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 [forall {b}. XCommand -> Message FRequest b
lxcmd XCommand
ClearWindow, forall a b. a -> Message a b
Low (GCId -> Point -> String -> FRequest
wDrawImageString GCId
drawGC Point
textpos String
text)]
                forall a. [a] -> [a] -> [a]
++ forall {b}. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
state forall a. Eq a => a -> a -> Bool
== BMevents
BMInverted) Point
size'
        buttonproc :: BMevents -> Point -> K hi (BMevents, Maybe Point)
buttonproc BMevents
bstate Point
size' =
          let same :: K hi (BMevents, Maybe Point)
same = BMevents -> Point -> K hi (BMevents, Maybe Point)
buttonproc BMevents
bstate Point
size'
              cont :: BMevents -> K hi (BMevents, Maybe Point)
cont BMevents
b = BMevents -> Point -> K hi (BMevents, Maybe Point)
buttonproc BMevents
b Point
size'
              redraw :: BMevents -> Point -> K hi (BMevents, Maybe Point)
redraw BMevents
b Point
s = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. BMevents -> Point -> [Message FRequest b]
drawit BMevents
b Point
s) (BMevents -> Point -> K hi (BMevents, Maybe Point)
buttonproc BMevents
b Point
s)
          in forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent hi
bmsg ->
               case KEvent hi
bmsg of
                 Low (XEvt (Expose Rect
_ Int
0)) -> BMevents -> Point -> K hi (BMevents, Maybe Point)
redraw BMevents
bstate Point
size'
                 Low (LEvt (LayoutSize Point
size'')) -> BMevents -> Point -> K hi (BMevents, Maybe Point)
redraw BMevents
bstate Point
size''
                 Low (XEvt (ButtonEvent Int
_ Point
_ Point
_ ModState
_ Pressed
Released Button
_)) ->
                   forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate forall a. Eq a => a -> a -> Bool
== BMevents
BMInverted) Point
size'
                           forall a. [a] -> [a] -> [a]
++ [forall a b. b -> Message a b
High (BMevents
BMClick, forall a. Maybe a
Nothing)])
                        (BMevents -> K hi (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 forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate forall a. Eq a => a -> a -> Bool
/= BMevents
BMInverted) Point
size'
                              forall a. [a] -> [a] -> [a]
++ [forall a b. b -> Message a b
High (BMevents
BMInverted, forall a. a -> Maybe a
Just Point
pos)])
                        (BMevents -> K hi (BMevents, Maybe Point)
cont BMevents
BMInverted)
                 Low (XEvt (LeaveNotify {})) ->
                   forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Bool -> Point -> [Message FRequest b]
invertitif (BMevents
bstate forall a. Eq a => a -> a -> Bool
/= BMevents
BMNormal) Point
size') (BMevents -> K hi (BMevents, Maybe Point)
cont BMevents
BMNormal)
                 KEvent hi
_ -> K hi (BMevents, Maybe Point)
same
    in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size Bool
True Bool
True))]
            (forall {hi}. BMevents -> Point -> K hi (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 hi (BMevents, Maybe Point))
altButton MenuTag t
alt = (MenuTag t
alt, forall {hi}.
(GCId, GCId, FontStruct)
-> Maybe Rect -> String -> F hi (BMevents, Maybe Point)
menuButtonF1 (GCId, GCId, FontStruct)
gcs forall a. Maybe a
Nothing (MenuTag t -> String
show_MenuTag MenuTag t
alt))
  in forall {a} {b} {c}.
Eq a =>
Placer -> [(a, F b c)] -> F (a, b) (a, c)
listLF (Int -> Placer
verticalP' Int
0) (forall a b. (a -> b) -> [a] -> [b]
map forall {hi}. MenuTag t -> (MenuTag t, F hi (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 = [forall {b}. XCommand -> Message FRequest b
lxcmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs,
	             forall {b}. XCommand -> Message FRequest b
lxcmd 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 = 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 forall {hi} {ho}. F hi ho -> F hi ho
delayF forall a b. (a -> b) -> a -> b
$
       forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF forall a b. (a -> b) -> a -> b
$
       forall a b c d.
Customiser ShellF -> K a b -> F c d -> F (Either a c) (Either b d)
shellKF' (forall xxx. HasMargin xxx => Int -> Customiser xxx
setMargin Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall xxx. HasVisible xxx => Bool -> Customiser xxx
setVisible Bool
False) (forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK forall {b}. [Message FRequest b]
startcmds forall {a} {a} {b} {a}.
K (Either (a, (a, b)) PopupSubMenu) (Either a (a, (a, b)))
subMenuK) 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 = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. XCommand -> Message FRequest b
lxcmd [XCommand
UnmapWindow]
      popup :: Point -> [Message FRequest b]
popup Point
p = forall a b. (a -> b) -> [a] -> [b]
map 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 =
        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 )) -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (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 =
        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) -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK 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))) ->
              forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [forall a b. b -> Message a b
High (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 forall a b. Int -> K a b -> K a b
setFontCursor Int
110 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 = forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (forall a b. K a b -> F a b
kernelF forall a.
Eq a =>
K (Either
     (MenuTag a, (MenuTag a, (BMevents, Maybe Point))) PopupSubMenu)
  (Either (MenuTag a, PopupSubMenu) a)
controlK forall {a} {b} {c} {d}.
F a b -> F c d -> F (Either a c) (Either b d)
>+< 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 :: forall a.
Eq a =>
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 =
        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 = forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
                   in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK 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) = forall {a}. Eq a => a -> [a] -> ([a], [a])
breakAt MenuTag a
tag [MenuTag a]
active
                       newlist :: [MenuTag a]
newlist = [forall a. String -> MenuTag a
SubTag String
s, MenuTag a
tag] forall a. [a] -> [a] -> [a]
++ [MenuTag a]
nlist
                       oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
olist
                       pos :: Point
pos = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Point
opoint
                   in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {a} {b}. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist forall a. [a] -> [a] -> [a]
++ [forall a b. b -> Message a b
High(forall a b. a -> Either a b
Left(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 = forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
                   in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {a} {b}. [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist forall a. [a] -> [a] -> [a]
++ [forall a b. b -> Message a b
High (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) = forall {a}. Eq a => a -> [a] -> ([a], [a])
breakAt MenuTag a
tag [MenuTag a]
active
                       newlist :: [MenuTag a]
newlist = [MenuTag a
tag] forall a. [a] -> [a] -> [a]
++ [MenuTag a]
nlist
                       oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
olist
                   in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK 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)) ->
              forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (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 [forall {a}. MenuTag a
mainTag])
            High (Right PopupSubMenu
PopdownSub) ->
              let oldlist :: [Message a (Either (MenuTag a, PopupSubMenu) b)]
oldlist = forall a b. (a -> b) -> [a] -> [b]
map (\MenuTag a
x -> forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (MenuTag a
x, PopupSubMenu
PopdownSub))) [MenuTag a]
active
              in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK 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 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 = 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
      routeClick :: a -> Either a b
routeClick = forall a b. a -> Either a b
Left
      optsize :: Maybe Point
optsize = 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)))) =
          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)))) =
          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}))) =
          forall {a} {a} {b}. a -> Message a (Either a b)
topopup (Bool
False, PopupSubMenu
PopdownSub)
      proc (Low FResponse
msg) = forall a b. a -> Message a b
Low FResponse
msg
      proc (High b
hi) = forall a b. b -> Message a b
High (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 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]]
      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 forall {hi} {ho}. [FRequest] -> Maybe Rect -> K hi ho -> F hi ho
swindowF [FRequest]
startcmds
             Maybe Rect
optrect
             (forall hi ho. KSP hi ho -> K hi ho
K forall a b. (a -> b) -> a -> b
$ forall {a} {b} {t}. SP a b -> (t -> a) -> SP t b
preMapSP KSP (Either (Bool, PopupSubMenu) String) PopupSubMenu
cdisp  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 = 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 [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 = 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 [forall {b}. XCommand -> Message FRequest b
lxcmd XCommand
ClearWindow, forall a b. a -> Message a b
Low (GCId -> Point -> String -> FRequest
wDrawImageString GCId
drawGC Point
textpos String
name)]
               forall a. [a] -> [a] -> [a]
++ 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 = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (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' = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (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 forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK 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 {})) ->
                 forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (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 {})) ->
                 forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (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)) ->
                  forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Bool -> Point -> [Message FRequest b]
invertitif (Bool
hi forall a. Eq a => a -> a -> Bool
/= Bool
highlighted) Point
size' forall a. [a] -> [a] -> [a]
++
                        [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 forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [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 :: forall a.
Eq a =>
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 =
   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
String -> (FontStruct -> f hi ho) -> f hi ho
safeLoadQueryFont String
fname forall a b. (a -> b) -> a -> b
$ \FontStruct
fs ->
   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
"black" forall a b. (a -> b) -> a -> b
$ \ Pixel
black ->
   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
"white" forall a b. (a -> b) -> a -> b
$ \ Pixel
white ->
   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC [forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, forall a b. b -> GCAttributes a b
GCFont (forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs)] forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
drawGC (forall {b}. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
black Pixel
white) 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 forall a. Eq a => a -> a -> Bool
== []
          then if [MenuTag a]
current 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 forall a. [a] -> [a] -> [a]
++ [(MenuTag a
tag, 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 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 forall a. [a] -> [a] -> [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 forall a. [a] -> [a] -> [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 (forall a. String -> MenuTag a
SubTag String
s) [MenuItem a]
z [] [(MenuTag a, F PopupSubMenu (MenuTag a, (BMevents, Maybe Point)))]
done)
   in forall {d}.
Eq d =>
[(MenuTag d, F PopupSubMenu (MenuTag d, (BMevents, Maybe Point)))]
-> F PopupSubMenu d
controlF (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 forall {a}. MenuTag a
mainTag [MenuItem a]
alts [] []) 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