module PopupGroupF(popupGroupF,rootPopupF) where
import Command
import CompOps((>=^^<), (>^^=<))
--import Direction
import Dlayout(unmappedGroupF)
import Sizing(Sizing(..))
import Shells(unmappedShellF)
--import Event
import Fudget
import FRequest
import Geometry(psub,pP)
import LayoutRequest
import LoopLow
--import Message(Message(..))
import ParK
--import Path(Path(..))
import Popupmsg
--import Spops
import MapstateK
import SpEither(filterRightSP)
--import SerCompF(concatMapF)
import Spops
--import Xtypes

popupGroupF :: (Size -> Size, [WindowAttributes], K b d)
-> F b d -> F (PopupMsg b) d
popupGroupF = ([FRequest]
 -> K (Either (Maybe Size) b) (Either Any d)
 -> F b d
 -> F (Either (Either (Maybe Size) b) b) (Either (Either Any d) d))
-> (Size -> Size, [WindowAttributes], K b d)
-> F b d
-> F (PopupMsg b) d
forall c b d t b b a1 d.
([FRequest]
 -> K (Either (Maybe Size) c) (Either b d)
 -> t
 -> F (Either (Either (Maybe Size) b) b) (Either a1 d))
-> (Size -> Size, [WindowAttributes], K c d)
-> t
-> F (PopupMsg b) d
popupF (Sizing
-> [FRequest]
-> K (Either (Maybe Size) b) (Either Any d)
-> F b d
-> F (Either (Either (Maybe Size) b) b) (Either (Either Any d) d)
forall a b c d.
Sizing
-> [FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
unmappedGroupF Sizing
Dynamic)
rootPopupF :: (Size -> Size, [WindowAttributes], K b d)
-> F b d -> F (PopupMsg b) d
rootPopupF  = ([FRequest]
 -> K (Either (Maybe Size) b) (Either Any d)
 -> F b d
 -> F (Either (Either (Maybe Size) b) b) (Either (Either Any d) d))
-> (Size -> Size, [WindowAttributes], K b d)
-> F b d
-> F (PopupMsg b) d
forall c b d t b b a1 d.
([FRequest]
 -> K (Either (Maybe Size) c) (Either b d)
 -> t
 -> F (Either (Either (Maybe Size) b) b) (Either a1 d))
-> (Size -> Size, [WindowAttributes], K c d)
-> t
-> F (PopupMsg b) d
popupF [FRequest]
-> K (Either (Maybe Size) b) (Either Any d)
-> F b d
-> F (Either (Either (Maybe Size) b) b) (Either (Either Any d) d)
forall (t :: * -> *) a b c d.
Foldable t =>
t FRequest -> K a b -> F c d -> F (Either a c) (Either b d)
unmappedShellF

popupF :: ([FRequest]
 -> K (Either (Maybe Size) c) (Either b d)
 -> t
 -> F (Either (Either (Maybe Size) b) b) (Either a1 d))
-> (Size -> Size, [WindowAttributes], K c d)
-> t
-> F (PopupMsg b) d
popupF [FRequest]
-> K (Either (Maybe Size) c) (Either b d)
-> t
-> F (Either (Either (Maybe Size) b) b) (Either a1 d)
grF (Size -> Size
offset, [WindowAttributes]
wattrs, K c d
k) t
f =
    let post :: (a, FRequest) -> [Message (a, FRequest) (a, FResponse)]
post (a
tag, FRequest
cmd) =
            case FRequest
cmd of
              LCmd LayoutMessage
req ->
	        case LayoutMessage
req of
--		  Layout size fh' fv -> [High (tag, LEvt $ LayoutPlace (Rect origin size))]
		  LayoutRequest (Layout {minsize :: LayoutRequest -> Size
minsize=Size
size}) ->
		    [(a, FResponse) -> Message (a, FRequest) (a, FResponse)
forall a b. b -> Message a b
High (a
tag, LayoutResponse -> FResponse
LEvt (LayoutResponse -> FResponse) -> LayoutResponse -> FResponse
forall a b. (a -> b) -> a -> b
$ Size -> LayoutResponse
LayoutSize Size
size)]
		    -- treated specially in windowKF.
		  LayoutMessage
_ -> []
              FRequest
cmd' -> [(a, FRequest) -> Message (a, FRequest) (a, FResponse)
forall a b. a -> Message a b
Low (a
tag, FRequest
cmd')]
        pre :: Message (a, FResponse) (a, FResponse) -> [(a, FResponse)]
pre Message (a, FResponse) (a, FResponse)
ev =
            case Message (a, FResponse) (a, FResponse)
ev of
              High (a, FResponse)
ev' -> [(a, FResponse)
ev']
              Low (a
_, LEvt (LayoutPlace Rect
_)) -> [] -- shouldn't happen?
              Low (a, FResponse)
tev -> [(a, FResponse)
tev]
        distr :: PopupMsg b -> [Either (Either (Maybe Size) b) b]
distr (Popup Size
p b
x) = [b -> Either (Either (Maybe Size) b) b
forall a b. b -> Either a b
Right b
x, Either (Maybe Size) b -> Either (Either (Maybe Size) b) b
forall a b. a -> Either a b
Left (Maybe Size -> Either (Maybe Size) b
forall a b. a -> Either a b
Left (Size -> Maybe Size
forall a. a -> Maybe a
Just Size
p))]
        distr PopupMsg b
Popdown = [Either (Maybe Size) b -> Either (Either (Maybe Size) b) b
forall a b. a -> Either a b
Left (Maybe Size -> Either (Maybe Size) b
forall a b. a -> Either a b
Left Maybe Size
forall a. Maybe a
Nothing)]
        startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs]
    in  (SP (Either a1 d) d
forall a1 b. SP (Either a1 b) b
filterRightSP SP (Either a1 d) d
-> F (Either (Either (Maybe Size) b) b) (Either a1 d)
-> F (Either (Either (Maybe Size) b) b) d
forall a b e. SP a b -> F e a -> F e b
>^^=<
         SP TCommand (FCommand (Path, FResponse))
-> SP (FEvent (Path, FResponse)) (Path, FResponse)
-> F (Either (Either (Maybe Size) b) b) (Either a1 d)
-> F (Either (Either (Maybe Size) b) b) (Either a1 d)
forall a b c.
SP TCommand (FCommand a)
-> SP (FEvent a) (Path, FResponse) -> F b c -> F b c
loopLow ((TCommand -> [FCommand (Path, FResponse)])
-> SP TCommand (FCommand (Path, FResponse))
forall t b. (t -> [b]) -> SP t b
concmapSP TCommand -> [FCommand (Path, FResponse)]
forall a. (a, FRequest) -> [Message (a, FRequest) (a, FResponse)]
post)
                 ((FEvent (Path, FResponse) -> [(Path, FResponse)])
-> SP (FEvent (Path, FResponse)) (Path, FResponse)
forall t b. (t -> [b]) -> SP t b
concmapSP FEvent (Path, FResponse) -> [(Path, FResponse)]
forall a. Message (a, FResponse) (a, FResponse) -> [(a, FResponse)]
pre)
                 ([FRequest]
-> K (Either (Maybe Size) c) (Either b d)
-> t
-> F (Either (Either (Maybe Size) b) b) (Either a1 d)
grF [FRequest]
startcmds (K (Maybe Size) b -> K c d -> K (Either (Maybe Size) c) (Either b d)
forall a b c d. K a b -> K c d -> K (Either a c) (Either b d)
compK ((Size -> Size) -> K (Maybe Size) b
forall ho. (Size -> Size) -> K (Maybe Size) ho
placeK Size -> Size
offset) K c d
k) t
f)) F (Either (Either (Maybe Size) b) b) d
-> SP (PopupMsg b) (Either (Either (Maybe Size) b) b)
-> F (PopupMsg b) d
forall c d e. F c d -> SP e c -> F e d
>=^^<
        (PopupMsg b -> [Either (Either (Maybe Size) b) b])
-> SP (PopupMsg b) (Either (Either (Maybe Size) b) b)
forall t b. (t -> [b]) -> SP t b
concatMapSP PopupMsg b -> [Either (Either (Maybe Size) b) b]
forall b b. PopupMsg b -> [Either (Either (Maybe Size) b) b]
distr

placeK :: (Size -> Size) -> K (Maybe Size) ho
placeK Size -> Size
offset = ((Bool, Size)
 -> KEvent (Maybe Size) -> ((Bool, Size), [KCommand ho]))
-> (Bool, Size) -> K (Maybe Size) ho
forall t hi ho.
(t -> KEvent hi -> (t, [KCommand ho])) -> t -> K hi ho
mapstateK (Bool, Size)
-> KEvent (Maybe Size) -> ((Bool, Size), [KCommand ho])
forall b.
(Bool, Size)
-> KEvent (Maybe Size) -> ((Bool, Size), [Message FRequest b])
sizeT (Bool
False,Int -> Int -> Size
pP Int
0 Int
0)
  where
    sizeT :: (Bool, Size)
-> KEvent (Maybe Size) -> ((Bool, Size), [Message FRequest b])
sizeT s :: (Bool, Size)
s@(Bool
mapped,Size
size) KEvent (Maybe Size)
msg =
      case KEvent (Maybe Size)
msg of
        High (Just Size
p) ->
	  ((Bool
True,Size
size),
	   [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 (Size -> XCommand
moveWindow (Size -> Size -> Size
psub Size
p (Size -> Size
offset Size
size)))] [Message FRequest b]
-> [Message FRequest b] -> [Message FRequest b]
forall a. [a] -> [a] -> [a]
++
	   if Bool -> Bool
not Bool
mapped then [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
MapRaised] else [])
	High Maybe Size
Nothing ->
	  ((Bool
False,Size
size),if Bool
mapped then [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] else [])
	Low (LEvt (LayoutSize Size
size')) ->
	  ((Bool
mapped,Size
size'), [])
	KEvent (Maybe Size)
_ -> ((Bool, Size)
s, [])