module ButtonGroupF(
buttonGroupF, menuButtonGroupF,
BMevents(..))
where
import Command
import CompOps((>=^<))
import Defaults(bgColor)
import Dlayout(groupF)
import Event
import Fudget
import FRequest
import Xcommand
import GreyBgF(changeBg)
import Loops(loopLeftF)
import Message(message)
import NullF
import Xtypes
import Utils
data BMevents = BMNormal | BMInverted | BMClick deriving (BMevents -> BMevents -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BMevents -> BMevents -> Bool
$c/= :: BMevents -> BMevents -> Bool
== :: BMevents -> BMevents -> Bool
$c== :: BMevents -> BMevents -> Bool
Eq, Eq BMevents
BMevents -> BMevents -> Bool
BMevents -> BMevents -> Ordering
BMevents -> BMevents -> BMevents
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
min :: BMevents -> BMevents -> BMevents
$cmin :: BMevents -> BMevents -> BMevents
max :: BMevents -> BMevents -> BMevents
$cmax :: BMevents -> BMevents -> BMevents
>= :: BMevents -> BMevents -> Bool
$c>= :: BMevents -> BMevents -> Bool
> :: BMevents -> BMevents -> Bool
$c> :: BMevents -> BMevents -> Bool
<= :: BMevents -> BMevents -> Bool
$c<= :: BMevents -> BMevents -> Bool
< :: BMevents -> BMevents -> Bool
$c< :: BMevents -> BMevents -> Bool
compare :: BMevents -> BMevents -> Ordering
$ccompare :: BMevents -> BMevents -> Ordering
Ord, Int -> BMevents -> ShowS
[BMevents] -> ShowS
BMevents -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BMevents] -> ShowS
$cshowList :: [BMevents] -> ShowS
show :: BMevents -> String
$cshow :: BMevents -> String
showsPrec :: Int -> BMevents -> ShowS
$cshowsPrec :: Int -> BMevents -> ShowS
Show)
buttonGroupF :: [(ModState, String)] -> F (Either BMevents b) c -> F b c
buttonGroupF = forall {b} {c}.
ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
buttonGroupF' ButtonParams
cmdButton
= forall {b} {c}.
ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
buttonGroupF' ButtonParams
menuButton []
buttonGroupF' :: ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
buttonGroupF' ButtonParams
bp [(ModState, String)]
keys F (Either BMevents b) c
f = forall a b c. F (Either a b) (Either a c) -> F b c
loopLeftF (forall {c} {d}.
ButtonParams
-> [(ModState, String)]
-> F c d
-> F (Either Bool c) (Either BMevents d)
buttonMachineF' ButtonParams
bp [(ModState, String)]
keys F (Either BMevents b) c
f forall c d e. F c d -> (e -> c) -> F e d
>=^< forall a b. b -> Either a b
Right)
buttonMachineF' :: ButtonParams
-> [(ModState, String)]
-> F c d
-> F (Either Bool c) (Either BMevents d)
buttonMachineF' ButtonParams
bp [(ModState, String)]
keys = forall {a} {b} {c} {d}.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [] (forall a b. String -> K a b -> K a b
changeBg String
bgColor (ButtonParams -> [(ModState, String)] -> K Bool BMevents
buttonK ButtonParams
bp [(ModState, String)]
keys))
data ButtonParams =
BP { ButtonParams -> ModState
modstate :: ModState,
ButtonParams -> Button
mbutton :: Button,
ButtonParams -> Button -> ModState -> K Bool BMevents
bmachine :: Button -> ModState -> K Bool BMevents }
elbMask :: [EventMask]
elbMask = [EventMask
EnterWindowMask, EventMask
LeaveWindowMask, EventMask
ButtonPressMask, EventMask
ButtonReleaseMask]
cmdButton :: ButtonParams
cmdButton =
BP { modstate :: ModState
modstate = [],
mbutton :: Button
mbutton = Int -> Button
Button Int
1,
bmachine :: Button -> ModState -> K Bool BMevents
bmachine = Button -> ModState -> K Bool BMevents
buttonMachine }
=
BP { modstate :: ModState
modstate = [],
mbutton :: Button
mbutton = Int -> Button
Button Int
1,
bmachine :: Button -> ModState -> K Bool BMevents
bmachine = Button -> ModState -> K Bool BMevents
mbuttonMachine }
buttonMachine :: Button -> ModState -> K Bool BMevents
buttonMachine Button
mousebutton ModState
modstate =
forall {i} {o}. [EventMask] -> K i o -> K i o
setEventMask [] forall a b. (a -> b) -> a -> b
$
forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Bool -> Button -> ModState -> [EventMask] -> XCommand
GrabButton Bool
False Button
mousebutton ModState
modstate [EventMask]
grabbedMask) forall a b. (a -> b) -> a -> b
$
BMevents -> K Bool BMevents
bm BMevents
BMNormal
where
grabbedMask :: [EventMask]
grabbedMask = [EventMask]
elbMask
switch :: BMevents -> K Bool BMevents
switch BMevents
newme = forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. b -> Message a b
High BMevents
newme) (BMevents -> K Bool BMevents
bm BMevents
newme)
pressed :: K Bool BMevents
pressed = BMevents -> K Bool BMevents
switch BMevents
BMInverted
normal :: K Bool BMevents
normal = BMevents -> K Bool BMevents
switch BMevents
BMNormal
clicked :: K Bool BMevents
clicked = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [forall a b. b -> Message a b
High BMevents
BMNormal, forall a b. b -> Message a b
High BMevents
BMClick] (BMevents -> K Bool BMevents
bm BMevents
BMNormal)
changeMode :: K Bool BMevents
changeMode =
forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Button -> ModState -> XCommand
UngrabButton Button
mousebutton ModState
modstate) forall a b. (a -> b) -> a -> b
$
Button -> ModState -> K Bool BMevents
mbuttonMachine Button
mousebutton ModState
modstate
bm :: BMevents -> K Bool BMevents
bm BMevents
me =
let nochange :: K Bool BMevents
nochange = BMevents -> K Bool BMevents
bm BMevents
me
in forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent Bool
msg ->
case KEvent Bool
msg of
Low (XEvt XEvent
event) ->
case XEvent
event of
(EnterNotify {detail :: XEvent -> Detail
detail=Detail
d}) | Detail
d forall a. Eq a => a -> a -> Bool
/= Detail
NotifyInferior -> K Bool BMevents
pressed
(LeaveNotify {detail :: XEvent -> Detail
detail=Detail
d}) | Detail
d forall a. Eq a => a -> a -> Bool
/= Detail
NotifyInferior -> K Bool BMevents
normal
(ButtonEvent {state :: XEvent -> ModState
state=ModState
s,type' :: XEvent -> Pressed
type'=Pressed
Pressed,button :: XEvent -> Button
button=Button
b})
| Button
b forall a. Eq a => a -> a -> Bool
== Button
mousebutton Bool -> Bool -> Bool
&& ModState
modstate forall {t1 :: * -> *} {t2 :: * -> *} {a}.
(Foldable t1, Foldable t2, Eq a) =>
t1 a -> t2 a -> Bool
`issubset` ModState
s -> K Bool BMevents
pressed
(ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Released,button :: XEvent -> Button
button=Button
b})
| Button
b forall a. Eq a => a -> a -> Bool
== Button
mousebutton -> if BMevents
me forall a. Eq a => a -> a -> Bool
== BMevents
BMInverted
then K Bool BMevents
clicked
else K Bool BMevents
nochange
(MenuPopupMode Bool
True) -> K Bool BMevents
changeMode
XEvent
_ -> K Bool BMevents
nochange
High Bool
True -> K Bool BMevents
changeMode
KEvent Bool
_ -> K Bool BMevents
nochange
mbuttonMachine :: Button -> ModState -> K Bool BMevents
mbuttonMachine Button
mousebutton ModState
modstate =
forall {i} {o}. [EventMask] -> K i o -> K i o
setEventMask [EventMask]
elbMask forall a b. (a -> b) -> a -> b
$
K Bool BMevents
loop
where
loop :: K Bool BMevents
loop = forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ forall {t1} {t2} {t3}.
(t1 -> t2) -> (t3 -> t2) -> Message t1 t3 -> t2
message FResponse -> K Bool BMevents
low Bool -> K Bool BMevents
high
out :: BMevents -> K Bool BMevents
out BMevents
e = forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. b -> Message a b
High BMevents
e) K Bool BMevents
loop
normal :: K Bool BMevents
normal = BMevents -> K Bool BMevents
out BMevents
BMNormal
pressed :: K Bool BMevents
pressed = BMevents -> K Bool BMevents
out BMevents
BMInverted
clicked :: K Bool BMevents
clicked = BMevents -> K Bool BMevents
out BMevents
BMClick
low :: FResponse -> K Bool BMevents
low (XEvt XEvent
ev) = XEvent -> K Bool BMevents
event XEvent
ev
low FResponse
_ = K Bool BMevents
loop
event :: XEvent -> K Bool BMevents
event (ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Released}) = K Bool BMevents
clicked
event (EnterNotify {}) = K Bool BMevents
pressed
event (LeaveNotify {}) = K Bool BMevents
normal
event (MenuPopupMode Bool
False) = Button -> ModState -> K Bool BMevents
buttonMachine Button
mousebutton ModState
modstate
event XEvent
_ = K Bool BMevents
loop
high :: Bool -> K Bool BMevents
high Bool
False = Button -> ModState -> K Bool BMevents
buttonMachine Button
mousebutton ModState
modstate
high Bool
_ = K Bool BMevents
loop
buttonK :: ButtonParams -> [(ModState, KeySym)] -> K Bool BMevents
buttonK :: ButtonParams -> [(ModState, String)] -> K Bool BMevents
buttonK (BP {mbutton :: ButtonParams -> Button
mbutton=Button
mbutton, modstate :: ButtonParams -> ModState
modstate=ModState
modstate, bmachine :: ButtonParams -> Button -> ModState -> K Bool BMevents
bmachine=Button -> ModState -> K Bool BMevents
bmachine }) [(ModState, String)]
keys =
forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
initcmds forall a b. (a -> b) -> a -> b
$ Button -> ModState -> K Bool BMevents
bmachine Button
mbutton ModState
modstate
where
initcmds :: [XCommand]
initcmds = [XCommand]
transinit forall a. [a] -> [a] -> [a]
++ [XCommand
MeButtonMachine]
transinit :: [XCommand]
transinit =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModState, String)]
keys
then []
else [(XEvent -> Maybe XEvent) -> [EventMask] -> XCommand
TranslateEvent XEvent -> Maybe XEvent
tobutton [EventMask
KeyPressMask, EventMask
KeyReleaseMask]]
tobutton :: XEvent -> Maybe XEvent
tobutton (KeyEvent Int
t Point
p1 Point
p2 ModState
s Pressed
pressed KeyCode
_ String
ks String
_) | (ModState
s, String
ks) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(ModState, String)]
keys =
forall a. a -> Maybe a
Just (Int -> Point -> Point -> ModState -> Pressed -> Button -> XEvent
ButtonEvent Int
t Point
p1 Point
p2 ModState
modstate Pressed
pressed Button
mbutton)
tobutton XEvent
_ = forall a. Maybe a
Nothing
setEventMask :: [EventMask] -> K i o -> K i o
setEventMask [EventMask]
mask = forall {i} {o}. XCommand -> K i o -> K i o
xcommandK ([WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
mask])