module WindowF(adjustBorderWidth,border_width,getBWidth,kernelF, toKernel, kernelTag,autumnize, windowKF) where
import Command
import CompOps((>+<))
import CompSP(prepostMapSP)
--import CompSP(serCompSP)
import Utils(pair,mapList)
import Direction
import Event
--import Font(FontStruct)
import Fudget
import FRequest
import Geometry(Point(..), Rect(..), origin, padd, pmax, rR)
import LayoutRequest
import LoopLow
--import Message(Message(..))
import NullF
import Path
--import SerCompF(idRightF)
import CompFfun(prepostMapLow)
import Spops
--import EitherUtils
import Data.Maybe(fromMaybe,isJust)
import Xtypes
import CmdLineEnv(argFlag)
--import DialogueIO hiding (IOError)

kernelF :: (K a b) -> F a b
kernelF :: forall a b. K a b -> F a b
kernelF (K KSP a b
proc) =
    let prep :: Message (a, a) b -> Message a b
prep (High b
a) = forall a b. b -> Message a b
High b
a
        prep (Low (a
_, a
b)) = forall a b. a -> Message a b
Low a
b
        post :: Message b b -> Message (Path, b) b
post (High b
a) = forall a b. b -> Message a b
High b
a
        post (Low b
b) = forall a b. a -> Message a b
Low (Path
here, b
b)
    in  {-F-}forall {hi} {ho}. FSP hi ho -> F hi ho
ff (forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP forall {a} {a} {b}. Message (a, a) b -> Message a b
prep forall {b} {b}. Message b b -> Message (Path, b) b
post KSP a b
proc)

toLowHere :: [a] -> [Message (Path, a) b]
toLowHere = forall {a} {b}. (a -> b) -> [a] -> [b]
mapList (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. a -> b -> (a, b)
pair Path
here)

winF :: (Rect -> FRequest) -> [FRequest] -> Rect -> K a b -> F a b
winF :: forall a b.
(Rect -> FRequest) -> [FRequest] -> Rect -> K a b -> F a b
winF Rect -> FRequest
winCmd [FRequest]
startcmds Rect
rect K a b
w =
    forall {ho} {hi}. [FCommand ho] -> F hi ho -> F hi ho
putMessagesF (forall {a} {b}. [a] -> [Message (Path, a) b]
toLowHere (Rect -> FRequest
winCmd Rect
rect forall a. a -> [a] -> [a]
: [FRequest]
startcmds)) (forall a b. K a b -> F a b
kernelF K a b
w)

newKTag :: Bool
newKTag = Bool -> Bool
not ([Char] -> Bool -> Bool
argFlag [Char]
"oldKTag" Bool
True) -- trouble with autolayout...

kernelTag :: Path
kernelTag = if Bool
newKTag then Path
here else Direction -> Path -> Path
turn Direction
L Path
here
autumnize :: [a] -> [a]
autumnize  = if Bool
newKTag then forall a. a -> a
id else forall {a}. [a] -> [a]
autumnize' where
  autumnize' :: [a] -> [a]
autumnize' [] = []
  autumnize' [a]
l = (forall {a}. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
reverse) [a]
l


toKernel :: [a] -> [Message (Path, a) b]
toKernel [a]
x = forall {a} {b}. (a -> b) -> [a] -> [b]
mapList (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. a -> b -> (a, b)
pair Path
kernelTag) [a]
x

getBWidth :: [WindowChanges] -> Maybe Int
getBWidth [WindowChanges]
cws = case [WindowChanges]
cws of
   [] -> forall a. Maybe a
Nothing
   CWBorderWidth Int
bw':[WindowChanges]
_ -> forall a. a -> Maybe a
Just Int
bw'
   WindowChanges
_:[WindowChanges]
cws -> [WindowChanges] -> Maybe Int
getBWidth [WindowChanges]
cws

adjustBorderWidth :: Int -> Point -> Point
adjustBorderWidth Int
b (Point Int
x Int
y) = Int -> Int -> Point
Point (Int
xforall a. Num a => a -> a -> a
+Int
b2) (Int
yforall a. Num a => a -> a -> a
+Int
b2) where b2 :: Int
b2 = Int
2forall a. Num a => a -> a -> a
*Int
b

border_width :: Int
border_width = Int
0::Int -- Should agree with the value in the core for XCreateSimpleWindow in xdecode.c and ghc-dialogue/DoXRequest.hs

windowKF :: (Rect -> FRequest) -> Bool -> Bool -> [FRequest] -> Maybe Rect -> K a b -> F c d -> F (Either a c) (Either b d)
windowKF :: forall a b c d.
(Rect -> FRequest)
-> Bool
-> Bool
-> [FRequest]
-> Maybe Rect
-> K a b
-> F c d
-> F (Either a c) (Either b d)
windowKF Rect -> FRequest
winCmd Bool
isShell Bool
nomap [FRequest]
startcmds Maybe Rect
oplace K a b
k F c d
f =
 let ctrlSP :: (Int, Bool)
-> SP
     (Either (Path, FRequest) (Path, FResponse))
     (Either (Path, FRequest) (Path, FResponse))
ctrlSP (Int
bw,Bool
nomap) =
       forall a b. Cont (SP a b) a
getSP forall a b. (a -> b) -> a -> b
$ \Either (Path, FRequest) (Path, FResponse)
msg ->
       let same :: SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same = (Int, Bool)
-> SP
     (Either (Path, FRequest) (Path, FResponse))
     (Either (Path, FRequest) (Path, FResponse))
ctrlSP (Int
bw,Bool
nomap)
           pass :: SP a (Either (Path, FRequest) (Path, FResponse))
-> SP a (Either (Path, FRequest) (Path, FResponse))
pass = forall b a. b -> SP a b -> SP a b
putSP Either (Path, FRequest) (Path, FResponse)
msg 
	   passame :: SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
passame = forall {a}.
SP a (Either (Path, FRequest) (Path, FResponse))
-> SP a (Either (Path, FRequest) (Path, FResponse))
pass SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same
	   adjB :: Int -> Point -> Point
adjB Int
b Point
s = if Bool
isShell then Point
s else Int -> Point -> Point
adjustBorderWidth Int
b Point
s
       in case Either (Path, FRequest) (Path, FResponse)
msg of
         Left (Path
tag,FRequest
cmd) -> case FRequest
cmd of
            XReq (CreateMyWindow Rect
r) | Path
tag forall a. Eq a => a -> a -> Bool
/= Path
kernelTag ->
		   forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
kernelTag, 
	                    XRequest -> FRequest
XReq (Path -> Rect -> XRequest
CreateSimpleWindow Path
tag Rect
r))) SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same
	    XCmd (ReparentToMe Path
r Window
w) | Path
r forall a. Eq a => a -> a -> Bool
== Path
here Bool -> Bool -> Bool
&& Path
tag forall a. Eq a => a -> a -> Bool
/= Path
kernelTag ->
		   forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
kernelTag,XCommand -> FRequest
XCmd (Path -> Window -> XCommand
ReparentToMe Path
tag Window
w))) SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same
            XCmd (ConfigureWindow [WindowChanges]
cws) | Path
tag forall a. Eq a => a -> a -> Bool
== Path
kernelTag -> 
	        -- hopefully, this occurs before LayoutMsg
		let bw' :: Int
bw' = forall a. a -> Maybe a -> a
fromMaybe Int
bw ([WindowChanges] -> Maybe Int
getBWidth [WindowChanges]
cws) in
		if Int
bw'forall a. Eq a => a -> a -> Bool
==Int
bw' then forall {a}.
SP a (Either (Path, FRequest) (Path, FResponse))
-> SP a (Either (Path, FRequest) (Path, FResponse))
pass forall a b. (a -> b) -> a -> b
$ (Int, Bool)
-> SP
     (Either (Path, FRequest) (Path, FResponse))
     (Either (Path, FRequest) (Path, FResponse))
ctrlSP (Int
bw',Bool
nomap) else forall a. HasCallStack => [Char] -> a
error [Char]
"windowKF"
            LCmd (LayoutRequest LayoutRequest
req) ->
	        forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
tag,LayoutRequest -> FRequest
layoutRequestCmd ((Point -> Point) -> LayoutRequest -> LayoutRequest
mapLayoutSize (Int -> Point -> Point
adjB Int
bw) LayoutRequest
req))) forall a b. (a -> b) -> a -> b
$
		SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same
	    FRequest
_ -> SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
passame
	 Right (Path
tag,FResponse
evt) -> case FResponse
evt of
	    XResp (WindowCreated Window
_) | Path
tagforall a. Eq a => a -> a -> Bool
==Path
kernelTag -> SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same 
	    -- does not correspond to internal request
            LEvt (LayoutPlace (Rect Point
p Point
s)) -> let ads :: Point
ads = Int -> Point -> Point
adjB (-Int
bw) Point
s in
	       forall b a. [b] -> SP a b -> SP a b
putsSP ([forall a b. b -> Either a b
Right (Path
tag, LayoutResponse -> FResponse
LEvt (Rect -> LayoutResponse
LayoutPlace (Point -> Point -> Rect
Rect Point
origin Point
ads))),
		      forall a b. b -> Either a b
Right (Path
kernelTag, LayoutResponse -> FResponse
LEvt (Point -> LayoutResponse
LayoutSize Point
ads)),
		      forall a b. b -> Either a b
Right (Path
kernelTag, LayoutResponse -> FResponse
LEvt (Point -> LayoutResponse
LayoutPos Point
p))] forall a. [a] -> [a] -> [a]
++   -- TH 990321
		       (if Bool
isShell then []
		        else forall {a} {b}. (a -> b) -> [a] -> [b]
mapList (forall a b. a -> Either a b
Leftforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. a -> b -> (a, b)
pair Path
kernelTag)
			         ([XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ Rect -> XCommand
moveResizeWindow (Rect -> Rect
checkSize (Point -> Point -> Rect
Rect Point
p Point
ads))] forall a. [a] -> [a] -> [a]
++
			          (if Bool
nomap Bool -> Bool -> Bool
|| Bool
static then []
				   else [XCommand -> FRequest
XCmd XCommand
MapRaised])))) forall a b. (a -> b) -> a -> b
$
               (Int, Bool)
-> SP
     (Either (Path, FRequest) (Path, FResponse))
     (Either (Path, FRequest) (Path, FResponse))
ctrlSP (Int
bw,Bool
True)
	    -- The LayoutSize message is not sent by the ordinary layout
	    -- system, but by popupGroupF for convenience, to resize the
	    -- window without moving it.
            LEvt (LayoutSize Point
s) -> let ads :: Point
ads = Int -> Point -> Point
adjB (-Int
bw) Point
s in
	       forall b a. [b] -> SP a b -> SP a b
putsSP ([forall a b. b -> Either a b
Right (Path
tag, LayoutResponse -> FResponse
LEvt (Rect -> LayoutResponse
LayoutPlace (Point -> Point -> Rect
Rect Point
origin Point
ads))),
		      forall a b. b -> Either a b
Right (Path
kernelTag, LayoutResponse -> FResponse
LEvt (Point -> LayoutResponse
LayoutSize Point
ads))] forall a. [a] -> [a] -> [a]
++
		       (if Bool
isShell then []
		        else [(forall a b. a -> Either a b
Leftforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. a -> b -> (a, b)
pair Path
kernelTag)
			        (XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ Point -> XCommand
resizeWindow (Point -> Point -> Point
pmax Point
ads Point
minSize))])) forall a b. (a -> b) -> a -> b
$
               SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
same
	    FResponse
_ -> SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
passame

     minSize :: Point
minSize = Int -> Int -> Point
Point Int
1 Int
1
     checkSize :: Rect -> Rect
checkSize (Rect Point
p Point
s) = Point -> Point -> Rect
Rect Point
p (Point -> Point -> Point
pmax Point
s Point
minSize)
     static :: Bool
static = forall a. Maybe a -> Bool
isJust Maybe Rect
oplace
     startplace :: Rect
startplace =
	 case Maybe Rect
oplace of
	   Maybe Rect
Nothing -> Int -> Int -> Int -> Int -> Rect
rR Int
0 Int
0 Int
10 Int
10
	   Just Rect
p -> Rect
p
     statlimits :: Rect -> FRequest
statlimits (Rect Point
p Point
s) = LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout (Point -> Point -> Point
padd Point
p Point
s) Bool
True Bool
True)
     wf :: F a b
wf =
	 forall a b.
(Rect -> FRequest) -> [FRequest] -> Rect -> K a b -> F a b
winF Rect -> FRequest
winCmd
	      ([FRequest]
startcmds forall a. [a] -> [a] -> [a]
++
	       (case Maybe Rect
oplace of
		  Maybe Rect
Nothing -> []
		  Just Rect
r -> [Rect -> FRequest
statlimits Rect
r] forall a. [a] -> [a] -> [a]
++
			    (if Bool
nomap then [] else [XCommand -> FRequest
XCmd XCommand
MapRaised])))
	      Rect
startplace
	      K a b
k
     wff :: F (Either a c) (Either b d)
wff = forall {hi} {ho}. F hi ho -> F hi ho
adjTag (F a b
wfforall {a} {b} {c} {d}.
F a b -> F c d -> F (Either a c) (Either b d)
>+<F c d
f)
     adjTag :: F hi ho -> F hi ho
adjTag = if Bool
newKTag then forall {hi} {ho}.
((Path, FResponse) -> (Path, FResponse))
-> ((Path, FRequest) -> (Path, FRequest)) -> F hi ho -> F hi ho
prepostMapLow forall {b}. (Path, b) -> (Path, b)
addktag forall {b}. (Path, b) -> (Path, b)
removektag else forall a. a -> a
id where
	    addktag :: (Path, b) -> (Path, b)
addktag ([],b
m) = ([Direction
L],b
m)
	    addktag (Path, b)
tm = (Path, b)
tm
	    removektag :: (Path, b) -> (Path, b)
removektag ([Direction
L],b
m) = ([],b
m)
	    removektag (Path, b)
tm = (Path, b)
tm

     windowf :: F (Either a c) (Either b d)
windowf = forall i o.
SP
  (Either (Path, FRequest) (Path, FResponse))
  (Either (Path, FRequest) (Path, FResponse))
-> F i o -> F i o
loopThroughLowF ((Int, Bool)
-> SP
     (Either (Path, FRequest) (Path, FResponse))
     (Either (Path, FRequest) (Path, FResponse))
ctrlSP (Int
border_width,Bool
nomap)) F (Either a c) (Either b d)
wff
     --windowf = windowf' ctrlSP nomap wf f
 in  case Maybe Rect
oplace of
          Maybe Rect
Nothing -> F (Either a c) (Either b d)
windowf
          Just Rect
place -> let prep' :: Message (a, FResponse) a -> [(a, FResponse)]
prep' (High a
ltag) = [(a
ltag, LayoutResponse -> FResponse
LEvt (Rect -> LayoutResponse
LayoutPlace Rect
place))]
                            prep' (Low (a
_, LEvt (LayoutPlace Rect
_))) = []
                            prep' (Low (a, FResponse)
msg) = [(a, FResponse)
msg]
                            post' :: (b, FRequest) -> [Message (b, FRequest) b]
post' (b
ltag, LCmd LayoutMessage
_) = [forall a b. b -> Message a b
High b
ltag]
                            post' (b, FRequest)
cmd = [forall a b. a -> Message a b
Low (b, FRequest)
cmd]
                        in  forall a b c.
SP (Path, FRequest) (FCommand a)
-> SP (FEvent a) (Path, FResponse) -> F b c -> F b c
loopLow (forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {b}. (b, FRequest) -> [Message (b, FRequest) b]
post') (forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {a}. Message (a, FResponse) a -> [(a, FResponse)]
prep') F (Either a c) (Either b d)
windowf

{-
windowf' ctrlSP nomap wf f =
  let wff = wf>+<f
      windowf = loopThroughLowF (ctrlSP (border_width,nomap)) wff
  in windowf
--}