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 :: String -> [WindowAttributes] -> F c a -> F (c, Maybe Point) (c, a)
posPopupShellF String
title [WindowAttributes]
wattrs F c a
f =
    forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (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 forall {b} {b}. K (Either b (b, Maybe Point)) (Either b (b, b))
popupK F c a
f)
  where
    startcmds :: [FRequest]
startcmds =
        [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ String -> XCommand
StoreName String
title,
	 XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ Point -> XCommand
SetNormalHints Point
origin,
	 XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs]

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