module PopupF(popupShellF,popupShellF') where
import Command
import DShellF
import FDefaults
import Fudget
import FRequest
import Xcommand
import Geometry(Point(..), pP)
--import LayoutRequest(LayoutRequest)
import Loops(loopCompThroughRightF)
--import Message(Message(..))
--import Spops
import MapstateK
import Xtypes
--import NullF(putsK)
import CompSP
import Path(here)

popupShellF :: String -> Maybe Point -> F a b -> F a (a, b)
popupShellF = Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a, b)
forall a b.
Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a, b)
popupShellF' Customiser ShellF
forall a. Customiser a
standard

popupShellF' :: Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a,b)
popupShellF' :: Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a, b)
popupShellF' Customiser ShellF
pm String
title Maybe Point
optpos (F FSP a b
f) =
  let pos :: Point
pos = case Maybe Point
optpos of
              Just Point
pos -> Point
pos
              Maybe Point
Nothing -> Int -> Int -> Point
pP Int
300 Int
300
      params :: Customiser ShellF
params = Customiser ShellF
pm Customiser ShellF -> Customiser ShellF -> Customiser ShellF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Customiser ShellF
forall xxx. HasVisible xxx => Bool -> Customiser xxx
setVisible Bool
False Customiser ShellF -> Customiser ShellF -> Customiser ShellF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Customiser ShellF
setDeleteQuit Bool
False
  in F (Either (Either b a) (Either a FRequest))
  (Either (Either (Either a FRequest) (a, b)) b)
-> F a (a, b)
forall a b c d.
F (Either (Either a b) c) (Either (Either c d) a) -> F b d
loopCompThroughRightF (Customiser ShellF
-> K (Either b a) (Either (Either a FRequest) (a, b))
-> F (Either a FRequest) b
-> F (Either (Either b a) (Either a FRequest))
     (Either (Either (Either a FRequest) (a, b)) b)
forall a b c d.
Customiser ShellF -> K a b -> F c d -> F (Either a c) (Either b d)
shellKF' Customiser ShellF
params (String
-> Point -> K (Either b a) (Either (Either a FRequest) (a, b))
forall b a.
String
-> Point -> K (Either b a) (Either (Either a FRequest) (a, b))
popupK String
title Point
pos) 
			   (FSP (Either a FRequest) b -> F (Either a FRequest) b
forall hi ho. FSP hi ho -> F hi ho
F{-ff-} (FSP (Either a FRequest) b -> F (Either a FRequest) b)
-> FSP (Either a FRequest) b -> F (Either a FRequest) b
forall a b. (a -> b) -> a -> b
$ (Message TEvent (Either a FRequest)
 -> Either (Message TEvent a) FRequest)
-> (Either (Message (Path, FRequest) b) FRequest
    -> Message (Path, FRequest) b)
-> SP
     (Either (Message TEvent a) FRequest)
     (Either (Message (Path, FRequest) b) FRequest)
-> FSP (Either a FRequest) b
forall t1 a t2 b. (t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP Message TEvent (Either a FRequest)
-> Either (Message TEvent a) FRequest
forall a b b. Message a (Either b b) -> Either (Message a b) b
pre Either (Message (Path, FRequest) b) FRequest
-> Message (Path, FRequest) b
forall b b. Either (Message (Path, b) b) b -> Message (Path, b) b
post (FSP a b
-> SP
     (Either (Message TEvent a) FRequest)
     (Either (Message (Path, FRequest) b) FRequest)
forall a1 a2 b. SP a1 a2 -> SP (Either a1 b) (Either a2 b)
idRightSP FSP a b
f)))

pre :: Message a (Either b b) -> Either (Message a b) b
pre (Low a
m) = Message a b -> Either (Message a b) b
forall a b. a -> Either a b
Left (a -> Message a b
forall a b. a -> Message a b
Low a
m)
pre (High (Left b
a)) = Message a b -> Either (Message a b) b
forall a b. a -> Either a b
Left (b -> Message a b
forall a b. b -> Message a b
High b
a)
pre (High (Right b
a)) = b -> Either (Message a b) b
forall a b. b -> Either a b
Right b
a
post :: Either (Message (Path, b) b) b -> Message (Path, b) b
post (Right b
a) = (Path, b) -> Message (Path, b) b
forall a b. a -> Message a b
Low (Path
here,b
a)
post (Left (Low (Path, b)
m)) = (Path, b) -> Message (Path, b) b
forall a b. a -> Message a b
Low (Path, b)
m
post (Left (High b
a)) = b -> Message (Path, b) b
forall a b. b -> Message a b
High b
a

popupK :: String
-> Point -> K (Either b a) (Either (Either a FRequest) (a, b))
popupK String
title Point
pos =
  let kf :: (Bool, a)
-> Message a (Either b a)
-> ((Bool, a),
    [Message FRequest (Either (Either a FRequest) (a, b))])
kf s :: (Bool, a)
s@(Bool
mapped,a
trig) Message a (Either b a)
msg =
	  case Message a (Either b a)
msg of
	    High (Right a
trig') -> ((Bool
True,a
trig'), 
	      [Either (Either a FRequest) (a, b)
-> Message FRequest (Either (Either a FRequest) (a, b))
forall a b. b -> Message a b
High (Either a FRequest -> Either (Either a FRequest) (a, b)
forall a b. a -> Either a b
Left (a -> Either a FRequest
forall a b. a -> Either a b
Left a
trig')),XCommand -> Message FRequest (Either (Either a FRequest) (a, b))
forall a a b. XCommand -> Message a (Either (Either a FRequest) b)
lowfromf (Bool -> XCommand
GrabEvents Bool
True)] [Message FRequest (Either (Either a FRequest) (a, b))]
-> [Message FRequest (Either (Either a FRequest) (a, b))]
-> [Message FRequest (Either (Either a FRequest) (a, b))]
forall a. [a] -> [a] -> [a]
++
	       if Bool -> Bool
not Bool
mapped then [FRequest -> Message FRequest (Either (Either a FRequest) (a, b))
forall a b. a -> Message a b
Low (FRequest -> Message FRequest (Either (Either a FRequest) (a, b)))
-> FRequest -> Message FRequest (Either (Either a FRequest) (a, b))
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
MapRaised] else [])
	    High (Left b
x) -> ((Bool
False,a
trig),
			      (if Bool
mapped then [Message FRequest (Either (Either a FRequest) (a, b))]
forall b. [Message FRequest b]
unmapcmds else []) [Message FRequest (Either (Either a FRequest) (a, b))]
-> [Message FRequest (Either (Either a FRequest) (a, b))]
-> [Message FRequest (Either (Either a FRequest) (a, b))]
forall a. [a] -> [a] -> [a]
++ 
			      [XCommand -> Message FRequest (Either (Either a FRequest) (a, b))
forall a a b. XCommand -> Message a (Either (Either a FRequest) b)
lowfromf XCommand
UngrabEvents,Either (Either a FRequest) (a, b)
-> Message FRequest (Either (Either a FRequest) (a, b))
forall a b. b -> Message a b
High ((a, b) -> Either (Either a FRequest) (a, b)
forall a b. b -> Either a b
Right (a
trig, b
x))])
	    Low a
_ -> ((Bool, a)
s, [])
      lowfromf :: XCommand -> Message a (Either (Either a FRequest) b)
lowfromf = Either (Either a FRequest) b
-> Message a (Either (Either a FRequest) b)
forall a b. b -> Message a b
High (Either (Either a FRequest) b
 -> Message a (Either (Either a FRequest) b))
-> (XCommand -> Either (Either a FRequest) b)
-> XCommand
-> Message a (Either (Either a FRequest) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a FRequest -> Either (Either a FRequest) b
forall a b. a -> Either a b
Left (Either a FRequest -> Either (Either a FRequest) b)
-> (XCommand -> Either a FRequest)
-> XCommand
-> Either (Either a FRequest) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FRequest -> Either a FRequest
forall a b. b -> Either a b
Right (FRequest -> Either a FRequest)
-> (XCommand -> FRequest) -> XCommand -> Either a FRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd
      unmapcmds :: [Message FRequest b]
unmapcmds = [FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (FRequest -> Message FRequest b) -> FRequest -> Message FRequest b
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
UnmapWindow,FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (FRequest -> Message FRequest b) -> FRequest -> Message FRequest b
forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd XCommand
Flush]
      startcmds :: [XCommand]
startcmds =
	  [String -> XCommand
StoreName String
title, Point -> XCommand
SetNormalHints Point
pos, Point -> XCommand
moveWindow Point
pos,
	   [WindowAttributes] -> XCommand
ChangeWindowAttributes [Bool -> WindowAttributes
CWSaveUnder Bool
True]]
  in [XCommand]
-> K (Either b a) (Either (Either a FRequest) (a, b))
-> K (Either b a) (Either (Either a FRequest) (a, b))
forall i o. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
startcmds (K (Either b a) (Either (Either a FRequest) (a, b))
 -> K (Either b a) (Either (Either a FRequest) (a, b)))
-> K (Either b a) (Either (Either a FRequest) (a, b))
-> K (Either b a) (Either (Either a FRequest) (a, b))
forall a b. (a -> b) -> a -> b
$
     ((Bool, a)
 -> KEvent (Either b a)
 -> ((Bool, a), [KCommand (Either (Either a FRequest) (a, b))]))
-> (Bool, a) -> K (Either b a) (Either (Either a FRequest) (a, b))
forall t hi ho.
(t -> KEvent hi -> (t, [KCommand ho])) -> t -> K hi ho
mapstateK (Bool, a)
-> KEvent (Either b a)
-> ((Bool, a), [KCommand (Either (Either a FRequest) (a, b))])
forall a a b.
(Bool, a)
-> Message a (Either b a)
-> ((Bool, a),
    [Message FRequest (Either (Either a FRequest) (a, b))])
kf (Bool
False,String -> a
forall a. HasCallStack => String -> a
error String
"premature output from fudget inside popupShellF")