module WindowF(adjustBorderWidth,border_width,getBWidth,kernelF, toKernel, kernelTag,autumnize, windowKF) where
import Command
import CompOps((>+<))
import CompSP(prepostMapSP)
import Utils(pair,mapList)
import Direction
import Event
import Fudget
import FRequest
import Geometry(Point(..), Rect(..), origin, padd, pmax, rR)
import LayoutRequest
import LoopLow
import NullF
import Path
import CompFfun(prepostMapLow)
import Spops
import Data.Maybe(fromMaybe,isJust)
import Xtypes
import CmdLineEnv(argFlag)
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 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)
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
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 ->
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
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]
++
(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)
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
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