module FreeGroupF(freeGroupF) where
import EitherUtils
import Path(here)
import LayoutRequest
import Geometry
import Dlayout(groupF)
import UserLayoutF(userLayoutF)
import Spops
import NullF(nullK)
import SerCompF(absF)
import LoopCompF(loopCompF)
import CompOps
import Defaults(bgColor)
import GreyBgF(changeBg)
freeGroupF :: F inr outr
-> F (Either (Either Size Size) inr) (Either LayoutMessage outr)
freeGroupF F inr outr
f =
forall r2l inl l2r inr outl outr.
F (Either (Either r2l inl) (Either l2r inr))
(Either (Either l2r outl) (Either r2l outr))
-> F (Either inl inr) (Either outl outr)
loopCompF (forall a b. SP a b -> F a b
absF SP
(Either (Path, LayoutMessage) (Either Size Size))
(Either (Path, Rect) LayoutMessage)
placeSP0forall {a} {b} {c} {d}.
F a b -> F c d -> F (Either a c) (Either b d)
>+<F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr)
innerF)
where
innerF :: F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr)
innerF = forall a b.
F a b -> F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
userLayoutF forall a b. (a -> b) -> a -> b
$
forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=< forall {a} {b} {c} {d}.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [] (forall {a} {b}. K a b -> K a b
bgK forall {hi} {ho}. K hi ho
nullK) F inr outr
f forall c d e. F c d -> (e -> c) -> F e d
>=^< forall a b. b -> Either a b
Right
placeSP0 :: SP
(Either (Path, LayoutMessage) (Either Size Size))
(Either (Path, Rect) LayoutMessage)
placeSP0 = forall {a}.
Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
False Path
here (Int -> Int -> Int -> Int -> Rect
rR Int
0 Int
0 Int
0 Int
0)
placeSP :: Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
placed a
path Rect
place =
let same :: SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
same = Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
placed a
path Rect
place
in
forall a b. Cont (SP a b) a
getSP forall a b. (a -> b) -> a -> b
$ \ Either (a, LayoutMessage) (Either Size Size)
msg ->
case Either (a, LayoutMessage) (Either Size Size)
msg of
Left (a
path',LayoutMessage
layoutmsg) ->
case LayoutMessage
layoutmsg of
LayoutRequest LayoutRequest
req ->
let place' :: Rect
place' = Rect -> Size -> Rect
sizerect Rect
place (LayoutRequest -> Size
minsize LayoutRequest
req)
in forall b a. b -> SP a b -> SP a b
putSP (forall a b. b -> Either a b
Right LayoutMessage
layoutmsg) forall a b. (a -> b) -> a -> b
$ Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
False a
path' Rect
place'
LayoutMakeVisible Rect
_ (Maybe Alignment, Maybe Alignment)
_ -> forall b a. b -> SP a b -> SP a b
putSP (forall a b. b -> Either a b
Right LayoutMessage
layoutmsg) SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
same
LayoutScrollStep Int
_ -> forall b a. b -> SP a b -> SP a b
putSP (forall a b. b -> Either a b
Right LayoutMessage
layoutmsg) SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
same
LayoutMessage
_ -> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
same
Right (Right Size
pos) ->
let place' :: Rect
place' = Rect -> Size -> Rect
posrect Rect
place Size
pos
in forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (a
path,Rect
place')) forall a b. (a -> b) -> a -> b
$
Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
True a
path Rect
place'
Right (Left Size
newtotsize) ->
let place' :: Rect
place' = Rect -> Size -> Rect
sizerect Rect
place Size
newtotsize
in forall {a}. Bool -> (a -> a) -> a -> a
ifSP (Bool -> Bool
not Bool
placed Bool -> Bool -> Bool
|| Rect
place'forall a. Eq a => a -> a -> Bool
/=Rect
place)
(forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (a
path,Rect
place'))) forall a b. (a -> b) -> a -> b
$
Bool
-> a
-> Rect
-> SP
(Either (a, LayoutMessage) (Either Size Size))
(Either (a, Rect) LayoutMessage)
placeSP Bool
True a
path Rect
place'
ifSP :: Bool -> (a -> a) -> a -> a
ifSP Bool
b a -> a
th = if Bool
b then a -> a
th else forall a. a -> a
id
bgK :: K a b -> K a b
bgK = forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor