module FreeGroupF(freeGroupF) where
--import Fudget
import EitherUtils
import Path(here)
import LayoutRequest
import Geometry
--import Command
--import Event
--import Xtypes

import Dlayout(groupF)
import UserLayoutF(userLayoutF)
import Spops
--import SpEither(mapFilterSP)
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) {- dummy initial path & place -}

    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 -- ignore other msgs for now
	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
$
	    --  ^^ dangerous optimization?
	     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