module PosPopupShellF(posPopupShellF) where
import Command
import Shells(unmappedShellF)
--import Event(Event(..))
import Fudget
import FRequest
import Geometry(origin, pP, psub)
--import LayoutRequest(LayoutRequest)
import Loops(loopCompThroughRightF)
--import Message(Message(..))
import NullF
--import Path(Path(..))
import QueryPointer
--import SP
--import Xtypes

posPopupShellF :: [Char] -> [WindowAttributes] -> F c a -> F (c, Maybe Point) (c, a)
posPopupShellF [Char]
title [WindowAttributes]
wattrs F c a
f =
    F (Either (Either a (c, Maybe Point)) c)
  (Either (Either c (c, a)) a)
-> F (c, Maybe Point) (c, a)
forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF ([FRequest]
-> K (Either a (c, Maybe Point)) (Either c (c, a))
-> F c a
-> F (Either (Either a (c, Maybe Point)) c)
     (Either (Either c (c, a)) a)
forall (t :: * -> *) a b c d.
Foldable t =>
t FRequest -> K a b -> F c d -> F (Either a c) (Either b d)
unmappedShellF [FRequest]
startcmds K (Either a (c, Maybe Point)) (Either c (c, a))
forall b a. K (Either b (a, Maybe Point)) (Either a (a, b))
popupK F c a
f)
  where
    startcmds :: [FRequest]
startcmds =
        [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [Char] -> XCommand
StoreName [Char]
title,
	 XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ Point -> XCommand
SetNormalHints Point
origin,
	 XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs]

popupK :: K (Either b (a, Maybe Point)) (Either a (a, b))
popupK = (Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
forall a b.
(Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
kf ([Char] -> (Bool, a)
forall a. HasCallStack => [Char] -> a
error [Char]
"premature output from fudget inside posPopupShellF")
  where
    pickPos :: Maybe Point -> (Point -> K b c) -> K b c
pickPos Maybe Point
p Point -> K b c
cont =
      case Maybe Point
p of
        Just Point
pos -> Point -> K b c
cont Point
pos
	Maybe Point
Nothing -> Cont (K b c) (Bool, Point, Point, ModState)
forall b c. Cont (K b c) (Bool, Point, Point, ModState)
queryPointerK (\(Bool
_, Point
r, Point
_, ModState
_) -> Point -> K b c
cont (Point -> Point -> Point
psub Point
r (Int -> Int -> Point
pP Int
5 Int
5)))

    kf :: (Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
kf s :: (Bool, a)
s@(Bool
mapped,a
trig) =
        Cont
  (K (Either b (a, Maybe Point)) (Either a (a, b)))
  (KEvent (Either b (a, Maybe Point)))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont
  (K (Either b (a, Maybe Point)) (Either a (a, b)))
  (KEvent (Either b (a, Maybe Point)))
-> Cont
     (K (Either b (a, Maybe Point)) (Either a (a, b)))
     (KEvent (Either b (a, Maybe Point)))
forall a b. (a -> b) -> a -> b
$ \KEvent (Either b (a, Maybe Point))
msg ->
        case KEvent (Either b (a, Maybe Point))
msg of
          High (Right (a
trig', Maybe Point
optpos)) ->
	    Maybe Point
-> (Point -> K (Either b (a, Maybe Point)) (Either a (a, b)))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall b c. Maybe Point -> (Point -> K b c) -> K b c
pickPos Maybe Point
optpos ((Point -> K (Either b (a, Maybe Point)) (Either a (a, b)))
 -> K (Either b (a, Maybe Point)) (Either a (a, b)))
-> (Point -> K (Either b (a, Maybe Point)) (Either a (a, b)))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ \Point
pos ->
            [KCommand (Either a (a, b))]
-> K (Either b (a, Maybe Point)) (Either a (a, b))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall b a. [KCommand b] -> K a b -> K a b
putsK ([FRequest -> KCommand (Either a (a, b))
forall a b. a -> Message a b
Low (FRequest -> KCommand (Either a (a, b)))
-> FRequest -> KCommand (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ Point -> XCommand
moveWindow Point
pos,
                    Either a (a, b) -> KCommand (Either a (a, b))
forall a b. b -> Message a b
High (a -> Either a (a, b)
forall a b. a -> Either a b
Left a
trig')] [KCommand (Either a (a, b))]
-> [KCommand (Either a (a, b))] -> [KCommand (Either a (a, b))]
forall a. [a] -> [a] -> [a]
++
                   if Bool -> Bool
not Bool
mapped then [FRequest -> KCommand (Either a (a, b))
forall a b. a -> Message a b
Low (FRequest -> KCommand (Either a (a, b)))
-> FRequest -> KCommand (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
MapRaised] else []) (K (Either b (a, Maybe Point)) (Either a (a, b))
 -> K (Either b (a, Maybe Point)) (Either a (a, b)))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall a b. (a -> b) -> a -> b
$
            (Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
kf (Bool
True,a
trig')
          High (Left b
y) ->
	    [KCommand (Either a (a, b))]
-> K (Either b (a, Maybe Point)) (Either a (a, b))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall b a. [KCommand b] -> K a b -> K a b
putsK ((if Bool
mapped then [FRequest -> KCommand (Either a (a, b))
forall a b. a -> Message a b
Low (FRequest -> KCommand (Either a (a, b)))
-> FRequest -> KCommand (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UnmapWindow] else []) [KCommand (Either a (a, b))]
-> [KCommand (Either a (a, b))] -> [KCommand (Either a (a, b))]
forall a. [a] -> [a] -> [a]
++
		   [Either a (a, b) -> KCommand (Either a (a, b))
forall a b. b -> Message a b
High ((a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
trig, b
y))]) (K (Either b (a, Maybe Point)) (Either a (a, b))
 -> K (Either b (a, Maybe Point)) (Either a (a, b)))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
-> K (Either b (a, Maybe Point)) (Either a (a, b))
forall a b. (a -> b) -> a -> b
$
            (Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
kf (Bool
False,a
trig)
          KEvent (Either b (a, Maybe Point))
_ -> (Bool, a) -> K (Either b (a, Maybe Point)) (Either a (a, b))
kf (Bool, a)
s