module ButtonGroupF(
	buttonGroupF, menuButtonGroupF,
	--buttonMachineF,
	BMevents(..))
where
import Command
import CompOps((>=^<))
import Defaults(bgColor)
import Dlayout(groupF)
import Event
import Fudget
import FRequest
import Xcommand
--import Geometry(Line, Point, Rect, Size(..))
import GreyBgF(changeBg)
--import LayoutRequest(LayoutRequest)
import Loops(loopLeftF)
import Message(message) --Message(..),
import NullF
--import SpEither(mapFilterSP)
import Xtypes
import Utils

data BMevents = BMNormal | BMInverted | BMClick  deriving (BMevents -> BMevents -> Bool
(BMevents -> BMevents -> Bool)
-> (BMevents -> BMevents -> Bool) -> Eq BMevents
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
Eq BMevents
-> (BMevents -> BMevents -> Ordering)
-> (BMevents -> BMevents -> Bool)
-> (BMevents -> BMevents -> Bool)
-> (BMevents -> BMevents -> Bool)
-> (BMevents -> BMevents -> Bool)
-> (BMevents -> BMevents -> BMevents)
-> (BMevents -> BMevents -> BMevents)
-> Ord 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
$cp1Ord :: Eq BMevents
Ord, Int -> BMevents -> ShowS
[BMevents] -> ShowS
BMevents -> String
(Int -> BMevents -> ShowS)
-> (BMevents -> String) -> ([BMevents] -> ShowS) -> Show BMevents
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     = ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
forall b c.
ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
buttonGroupF' ButtonParams
cmdButton
menuButtonGroupF :: F (Either BMevents b) c -> F b c
menuButtonGroupF = ButtonParams
-> [(ModState, String)] -> F (Either BMevents b) c -> F b c
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 = F (Either BMevents b) (Either BMevents c) -> F b c
forall a b c. F (Either a b) (Either a c) -> F b c
loopLeftF (ButtonParams
-> [(ModState, String)]
-> F (Either BMevents b) c
-> F (Either Bool (Either BMevents b)) (Either BMevents c)
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 F (Either Bool (Either BMevents b)) (Either BMevents c)
-> (Either BMevents b -> Either Bool (Either BMevents b))
-> F (Either BMevents b) (Either BMevents c)
forall c d e. F c d -> (e -> c) -> F e d
>=^< Either BMevents b -> Either Bool (Either BMevents b)
forall a b. b -> Either a b
Right)

--buttonMachineF = buttonMachineF' cmdButton

buttonMachineF' :: ButtonParams
-> [(ModState, String)]
-> F c d
-> F (Either Bool c) (Either BMevents d)
buttonMachineF' ButtonParams
bp [(ModState, String)]
keys = [FRequest]
-> K Bool BMevents
-> F c d
-> F (Either Bool c) (Either BMevents d)
forall a b c d.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [] (String -> K Bool BMevents -> K Bool BMevents
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
-> Button
-> (Button -> ModState -> K Bool BMevents)
-> ButtonParams
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 }

menuButton :: ButtonParams
menuButton =
  BP :: ModState
-> Button
-> (Button -> ModState -> K Bool BMevents)
-> ButtonParams
BP { modstate :: ModState
modstate = [],
       mbutton :: Button
mbutton = Int -> Button
Button Int
1, -- not used
       bmachine :: Button -> ModState -> K Bool BMevents
bmachine = Button -> ModState -> K Bool BMevents
mbuttonMachine }

buttonMachine :: Button -> ModState -> K Bool BMevents
buttonMachine Button
mousebutton ModState
modstate =
    [EventMask] -> K Bool BMevents -> K Bool BMevents
forall i o. [EventMask] -> K i o -> K i o
setEventMask [] (K Bool BMevents -> K Bool BMevents)
-> K Bool BMevents -> K Bool BMevents
forall a b. (a -> b) -> a -> b
$
    XCommand -> K Bool BMevents -> K Bool BMevents
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) (K Bool BMevents -> K Bool BMevents)
-> K Bool BMevents -> K Bool BMevents
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 = KCommand BMevents -> K Bool BMevents -> K Bool BMevents
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (BMevents -> KCommand BMevents
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 = [KCommand BMevents] -> K Bool BMevents -> K Bool BMevents
forall b a. [KCommand b] -> K a b -> K a b
putsK [BMevents -> KCommand BMevents
forall a b. b -> Message a b
High BMevents
BMNormal, BMevents -> KCommand BMevents
forall a b. b -> Message a b
High BMevents
BMClick] (BMevents -> K Bool BMevents
bm BMevents
BMNormal)
    changeMode :: K Bool BMevents
changeMode =
	-- switch to menu button mode
	XCommand -> K Bool BMevents -> K Bool BMevents
forall i o. XCommand -> K i o -> K i o
xcommandK (Button -> ModState -> XCommand
UngrabButton Button
mousebutton ModState
modstate) (K Bool BMevents -> K Bool BMevents)
-> K Bool BMevents -> K Bool BMevents
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 Cont (K Bool BMevents) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool BMevents) (KEvent Bool)
-> Cont (K Bool BMevents) (KEvent Bool)
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 Detail -> Detail -> Bool
forall a. Eq a => a -> a -> Bool
/= Detail
NotifyInferior -> K Bool BMevents
pressed
	       (LeaveNotify {detail :: XEvent -> Detail
detail=Detail
d}) | Detail
d Detail -> Detail -> Bool
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 Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
mousebutton Bool -> Bool -> Bool
&& ModState
modstate ModState -> ModState -> Bool
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 Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
mousebutton -> if BMevents
me BMevents -> BMevents -> Bool
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 =
    [EventMask] -> K Bool BMevents -> K Bool BMevents
forall i o. [EventMask] -> K i o -> K i o
setEventMask [EventMask]
elbMask (K Bool BMevents -> K Bool BMevents)
-> K Bool BMevents -> K Bool BMevents
forall a b. (a -> b) -> a -> b
$
    K Bool BMevents
loop
  where
    loop :: K Bool BMevents
loop = Cont (K Bool BMevents) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool BMevents) (KEvent Bool)
-> Cont (K Bool BMevents) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ (FResponse -> K Bool BMevents)
-> (Bool -> K Bool BMevents) -> KEvent Bool -> K Bool BMevents
forall t1 p t2. (t1 -> p) -> (t2 -> p) -> Message t1 t2 -> p
message FResponse -> K Bool BMevents
low Bool -> K Bool BMevents
high
    out :: BMevents -> K Bool BMevents
out BMevents
e = KCommand BMevents -> K Bool BMevents -> K Bool BMevents
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (BMevents -> KCommand BMevents
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 =
    [XCommand] -> K Bool BMevents -> K Bool BMevents
forall i o. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
initcmds (K Bool BMevents -> K Bool BMevents)
-> K Bool BMevents -> K Bool BMevents
forall a b. (a -> b) -> a -> b
$ Button -> ModState -> K Bool BMevents
bmachine Button
mbutton ModState
modstate
  where
    initcmds :: [XCommand]
initcmds = [XCommand]
transinit [XCommand] -> [XCommand] -> [XCommand]
forall a. [a] -> [a] -> [a]
++ [XCommand
MeButtonMachine]

    transinit :: [XCommand]
transinit =
	if [(ModState, String)] -> Bool
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) (ModState, String) -> [(ModState, String)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(ModState, String)]
keys =
	XEvent -> Maybe XEvent
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
_ = Maybe XEvent
forall a. Maybe a
Nothing

setEventMask :: [EventMask] -> K i o -> K i o
setEventMask [EventMask]
mask = XCommand -> K i o -> K i o
forall i o. XCommand -> K i o -> K i o
xcommandK ([WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
mask])