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 =
    F (Either
     (Either (Path, LayoutMessage) (Either Size Size))
     (Either (Path, Rect) inr))
  (Either
     (Either (Path, Rect) LayoutMessage)
     (Either (Path, LayoutMessage) outr))
-> F (Either (Either Size Size) inr) (Either LayoutMessage outr)
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 (SP
  (Either (Path, LayoutMessage) (Either Size Size))
  (Either (Path, Rect) LayoutMessage)
-> F (Either (Path, LayoutMessage) (Either Size Size))
     (Either (Path, Rect) LayoutMessage)
forall a b. SP a b -> F a b
absF SP
  (Either (Path, LayoutMessage) (Either Size Size))
  (Either (Path, Rect) LayoutMessage)
placeSP0F (Either (Path, LayoutMessage) (Either Size Size))
  (Either (Path, Rect) LayoutMessage)
-> F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr)
-> F (Either
        (Either (Path, LayoutMessage) (Either Size Size))
        (Either (Path, Rect) inr))
     (Either
        (Either (Path, Rect) LayoutMessage)
        (Either (Path, LayoutMessage) outr))
forall 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 = F inr outr
-> F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr)
forall a b.
F a b -> F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
userLayoutF (F inr outr
 -> F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr))
-> F inr outr
-> F (Either (Path, Rect) inr) (Either (Path, LayoutMessage) outr)
forall a b. (a -> b) -> a -> b
$
             Either outr outr -> outr
forall p. Either p p -> p
stripEither (Either outr outr -> outr)
-> F (Either Any inr) (Either outr outr) -> F (Either Any inr) outr
forall a b e. (a -> b) -> F e a -> F e b
>^=< [FRequest]
-> K Any outr
-> F inr outr
-> F (Either Any inr) (Either outr outr)
forall a b c d.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [] (K Any outr -> K Any outr
forall a b. K a b -> K a b
bgK K Any outr
forall hi ho. K hi ho
nullK) F inr outr
f F (Either Any inr) outr -> (inr -> Either Any inr) -> F inr outr
forall c d e. F c d -> (e -> c) -> F e d
>=^< inr -> Either Any inr
forall a b. b -> Either a b
Right

    placeSP0 :: SP
  (Either (Path, LayoutMessage) (Either Size Size))
  (Either (Path, Rect) LayoutMessage)
placeSP0 = Bool
-> Path
-> Rect
-> SP
     (Either (Path, LayoutMessage) (Either Size Size))
     (Either (Path, Rect) LayoutMessage)
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 
      Cont
  (SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage))
  (Either (a, LayoutMessage) (Either Size Size))
forall a b. Cont (SP a b) a
getSP Cont
  (SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage))
  (Either (a, LayoutMessage) (Either Size Size))
-> Cont
     (SP
        (Either (a, LayoutMessage) (Either Size Size))
        (Either (a, Rect) LayoutMessage))
     (Either (a, LayoutMessage) (Either Size Size))
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 Either (a, Rect) LayoutMessage
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall b a. b -> SP a b -> SP a b
putSP (LayoutMessage -> Either (a, Rect) LayoutMessage
forall a b. b -> Either a b
Right LayoutMessage
layoutmsg) (SP
   (Either (a, LayoutMessage) (Either Size Size))
   (Either (a, Rect) LayoutMessage)
 -> SP
      (Either (a, LayoutMessage) (Either Size Size))
      (Either (a, Rect) LayoutMessage))
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
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)
_ -> Either (a, Rect) LayoutMessage
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall b a. b -> SP a b -> SP a b
putSP (LayoutMessage -> Either (a, Rect) LayoutMessage
forall a b. b -> Either a b
Right LayoutMessage
layoutmsg) SP
  (Either (a, LayoutMessage) (Either Size Size))
  (Either (a, Rect) LayoutMessage)
same
	    LayoutScrollStep Int
_ -> Either (a, Rect) LayoutMessage
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall b a. b -> SP a b -> SP a b
putSP (LayoutMessage -> Either (a, Rect) LayoutMessage
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 Either (a, Rect) LayoutMessage
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall b a. b -> SP a b -> SP a b
putSP ((a, Rect) -> Either (a, Rect) LayoutMessage
forall a b. a -> Either a b
Left (a
path,Rect
place')) (SP
   (Either (a, LayoutMessage) (Either Size Size))
   (Either (a, Rect) LayoutMessage)
 -> SP
      (Either (a, LayoutMessage) (Either Size Size))
      (Either (a, Rect) LayoutMessage))
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
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 Bool
-> (SP
      (Either (a, LayoutMessage) (Either Size Size))
      (Either (a, Rect) LayoutMessage)
    -> SP
         (Either (a, LayoutMessage) (Either Size Size))
         (Either (a, Rect) LayoutMessage))
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall a. Bool -> (a -> a) -> a -> a
ifSP (Bool -> Bool
not Bool
placed Bool -> Bool -> Bool
|| Rect
place'Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
/=Rect
place)
                  (Either (a, Rect) LayoutMessage
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
forall b a. b -> SP a b -> SP a b
putSP ((a, Rect) -> Either (a, Rect) LayoutMessage
forall a b. a -> Either a b
Left (a
path,Rect
place'))) (SP
   (Either (a, LayoutMessage) (Either Size Size))
   (Either (a, Rect) LayoutMessage)
 -> SP
      (Either (a, LayoutMessage) (Either Size Size))
      (Either (a, Rect) LayoutMessage))
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
-> SP
     (Either (a, LayoutMessage) (Either Size Size))
     (Either (a, Rect) LayoutMessage)
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 a -> a
forall a. a -> a
id

bgK :: K a b -> K a b
bgK = ColorName -> K a b -> K a b
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor