module SuperMenuF (superMenuF, MenuItem (..)) where
import AllFudgets
import Data.Maybe(fromJust)
import HbcUtils(breakAt)
data a =
Item a
| (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 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 =
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
(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)
(GCId, GCId, FontStruct)
gcs [MenuTag t]
alts t -> String
show_alt =
let
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)
(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
=
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
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