module NameLayout(LName(..),placeNL,spaceNL,modNL,marginNL,sepNL,hvAlignNL,marginHVAlignNL,nullNL,hBoxNL,hBoxNL',vBoxNL, vBoxNL',leafNL, NameLayout, nameF,
 listNF, nameLayoutF) where

--import NonStdTrace(trace)
import LayoutRequest
import NullF
import Spops
--import Command
--import Event
import FRequest
--import Xtypes
import EitherUtils(plookup)
import Data.Maybe(fromJust)
import Fudget
import Path
import Geometry
import Placers
import Spacers
--import Message
import ListF
import Loopthrough
import Cont
--import LayoutDir
import AlignP
--import Alignment
import Utils
import Maptrace
import AutoLayout
import ParF

type LName = String
newtype NameLayout = NL (MLNode LName) -- abstract

-- The layout structure datatype
type MLNode a = (Maybe LayoutRequest, LNode a)
data LNode a = 
      LNode Int Placer (Maybe (Rect -> [Rect])) [MLNode a]
    | LLeaf (LLeaf a) deriving Int -> LNode a -> ShowS
[LNode a] -> ShowS
LNode a -> String
(Int -> LNode a -> ShowS)
-> (LNode a -> String) -> ([LNode a] -> ShowS) -> Show (LNode a)
forall a. Show a => Int -> LNode a -> ShowS
forall a. Show a => [LNode a] -> ShowS
forall a. Show a => LNode a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LNode a] -> ShowS
$cshowList :: forall a. Show a => [LNode a] -> ShowS
show :: LNode a -> String
$cshow :: forall a. Show a => LNode a -> String
showsPrec :: Int -> LNode a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LNode a -> ShowS
Show

data LLeaf a = Name a | Req LayoutRequest deriving Int -> LLeaf a -> ShowS
[LLeaf a] -> ShowS
LLeaf a -> String
(Int -> LLeaf a -> ShowS)
-> (LLeaf a -> String) -> ([LLeaf a] -> ShowS) -> Show (LLeaf a)
forall a. Show a => Int -> LLeaf a -> ShowS
forall a. Show a => [LLeaf a] -> ShowS
forall a. Show a => LLeaf a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LLeaf a] -> ShowS
$cshowList :: forall a. Show a => [LLeaf a] -> ShowS
show :: LLeaf a -> String
$cshow :: forall a. Show a => LLeaf a -> String
showsPrec :: Int -> LLeaf a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LLeaf a -> ShowS
Show

type NPath = [Int]

-----------------------------------------------------------------------------------
-- Exported functions

placeNL :: Placer -> [NameLayout] -> NameLayout
placeNL :: Placer -> [NameLayout] -> NameLayout
placeNL Placer
lter [NameLayout]
ns = let dns :: [MLNode String]
dns = (NameLayout -> MLNode String) -> [NameLayout] -> [MLNode String]
forall a b. (a -> b) -> [a] -> [b]
map NameLayout -> MLNode String
deNL [NameLayout]
ns in
   LNode String -> NameLayout
buildnl (LNode String -> NameLayout) -> LNode String -> NameLayout
forall a b. (a -> b) -> a -> b
$ Int
-> Placer
-> Maybe (Rect -> [Rect])
-> [MLNode String]
-> LNode String
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode ([MLNode String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((MLNode String -> Bool) -> [MLNode String] -> [MLNode String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe LayoutRequest -> Bool
forall a. Maybe a -> Bool
nothing(Maybe LayoutRequest -> Bool)
-> (MLNode String -> Maybe LayoutRequest) -> MLNode String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.MLNode String -> Maybe LayoutRequest
forall a b. (a, b) -> a
fst) [MLNode String]
dns)) Placer
lter Maybe (Rect -> [Rect])
forall a. Maybe a
Nothing [MLNode String]
dns

spaceNL :: Spacer -> NameLayout -> NameLayout
spaceNL :: Spacer -> NameLayout -> NameLayout
spaceNL = (Placer -> Placer) -> NameLayout -> NameLayout
modNL ((Placer -> Placer) -> NameLayout -> NameLayout)
-> (Spacer -> Placer -> Placer)
-> Spacer
-> NameLayout
-> NameLayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spacer -> Placer -> Placer
spacerP

modNL :: (Placer -> Placer) -> NameLayout -> NameLayout
modNL :: (Placer -> Placer) -> NameLayout -> NameLayout
modNL Placer -> Placer
ltermod (NL (Maybe LayoutRequest
req,LNode String
n)) = MLNode String -> NameLayout
NL (MLNode String -> NameLayout) -> MLNode String -> NameLayout
forall a b. (a -> b) -> a -> b
$ case LNode String
n of
   LNode Int
i Placer
lter Maybe (Rect -> [Rect])
f [MLNode String]
ls -> (Maybe LayoutRequest
req,Int
-> Placer
-> Maybe (Rect -> [Rect])
-> [MLNode String]
-> LNode String
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode Int
i (Placer -> Placer
ltermod Placer
lter) Maybe (Rect -> [Rect])
f [MLNode String]
ls)
   LLeaf LLeaf String
l -> 
      let lter :: Placer
lter = Placer -> Placer
ltermod Placer
idP
          P Placer1
lter' = Placer
lter in 
      case LLeaf String
l of
	 Req LayoutRequest
r -> LayoutRequest -> MLNode String
forall a. LayoutRequest -> MLNode a
leafReq (LayoutRequest -> MLNode String) -> LayoutRequest -> MLNode String
forall a b. (a -> b) -> a -> b
$ (LayoutRequest, Rect -> [Rect]) -> LayoutRequest
forall a b. (a, b) -> a
fst ((LayoutRequest, Rect -> [Rect]) -> LayoutRequest)
-> (LayoutRequest, Rect -> [Rect]) -> LayoutRequest
forall a b. (a -> b) -> a -> b
$ Placer1
lter' Placer1 -> Placer1
forall a b. (a -> b) -> a -> b
$ [LayoutRequest
r]
	 LLeaf String
_ -> (Maybe LayoutRequest
forall a. Maybe a
Nothing,Int
-> Placer
-> Maybe (Rect -> [Rect])
-> [MLNode String]
-> LNode String
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode Int
1 Placer
lter Maybe (Rect -> [Rect])
forall a. Maybe a
Nothing [(Maybe LayoutRequest
req,LNode String
n)])

marginNL :: Int -> NameLayout -> NameLayout
marginNL = Spacer -> NameLayout -> NameLayout
spaceNL (Spacer -> NameLayout -> NameLayout)
-> (Int -> Spacer) -> Int -> NameLayout -> NameLayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Spacer
marginS
sepNL :: Size -> NameLayout -> NameLayout
sepNL = Spacer -> NameLayout -> NameLayout
spaceNL (Spacer -> NameLayout -> NameLayout)
-> (Size -> Spacer) -> Size -> NameLayout -> NameLayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Spacer
sepS

hvAlignNL :: Alignment -> Alignment -> NameLayout -> NameLayout
hvAlignNL = Spacer -> NameLayout -> NameLayout
spaceNL (Spacer -> NameLayout -> NameLayout)
-> (Alignment -> Alignment -> Spacer)
-> Alignment
-> Alignment
-> NameLayout
-> NameLayout
forall t1 t2 t3 t4.
(t1 -> t2) -> (t3 -> t4 -> t1) -> t3 -> t4 -> t2
`oo` Alignment -> Alignment -> Spacer
hvAlignS
marginHVAlignNL :: Int -> Alignment -> Alignment -> NameLayout -> NameLayout
marginHVAlignNL Int
sep Alignment
ha Alignment
va = Spacer -> NameLayout -> NameLayout
spaceNL (Int -> Alignment -> Alignment -> Spacer
marginHVAlignS Int
sep Alignment
ha Alignment
va)

hBoxNL :: [NameLayout] -> NameLayout
hBoxNL = Placer -> [NameLayout] -> NameLayout
placeNL (Placer -> [NameLayout] -> NameLayout)
-> Placer -> [NameLayout] -> NameLayout
forall a b. (a -> b) -> a -> b
$ Placer
horizontalP
hBoxNL' :: Int -> [NameLayout] -> NameLayout
hBoxNL' Int
d = Placer -> [NameLayout] -> NameLayout
placeNL (Placer -> [NameLayout] -> NameLayout)
-> Placer -> [NameLayout] -> NameLayout
forall a b. (a -> b) -> a -> b
$ Int -> Placer
horizontalP' Int
d
vBoxNL :: [NameLayout] -> NameLayout
vBoxNL = Placer -> [NameLayout] -> NameLayout
placeNL (Placer -> [NameLayout] -> NameLayout)
-> Placer -> [NameLayout] -> NameLayout
forall a b. (a -> b) -> a -> b
$ Placer
verticalP
vBoxNL' :: Int -> [NameLayout] -> NameLayout
vBoxNL' Int
d = Placer -> [NameLayout] -> NameLayout
placeNL (Placer -> [NameLayout] -> NameLayout)
-> Placer -> [NameLayout] -> NameLayout
forall a b. (a -> b) -> a -> b
$ Int -> Placer
verticalP' Int
d
leafNL :: String -> NameLayout
leafNL String
name = LNode String -> NameLayout
buildnl (LNode String -> NameLayout) -> LNode String -> NameLayout
forall a b. (a -> b) -> a -> b
$ LLeaf String -> LNode String
forall a. LLeaf a -> LNode a
LLeaf (LLeaf String -> LNode String) -> LLeaf String -> LNode String
forall a b. (a -> b) -> a -> b
$ String -> LLeaf String
forall a. a -> LLeaf a
Name String
name
nullNL :: NameLayout
nullNL = MLNode String -> NameLayout
NL (MLNode String -> NameLayout) -> MLNode String -> NameLayout
forall a b. (a -> b) -> a -> b
$ LayoutRequest -> MLNode String
forall a. LayoutRequest -> MLNode a
leafReq (LayoutRequest -> MLNode String) -> LayoutRequest -> MLNode String
forall a b. (a -> b) -> a -> b
$ Size -> Bool -> Bool -> LayoutRequest
plainLayout (Int -> Int -> Size
Point Int
1 Int
1) Bool
False Bool
False

nameF :: LName -> F a b -> F a b
nameF :: String -> F a b -> F a b
nameF String
n = Message FRequest b -> F a b -> F a b
forall ho hi. Message FRequest ho -> F hi ho -> F hi ho
putMessageFu (FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd (String -> LayoutMessage
LayoutName String
n))) (F a b -> F a b) -> (F a b -> F a b) -> F a b -> F a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F a b -> F a b
forall a b. F a b -> F a b
autoLayoutF

-- local

nothing :: Maybe a -> Bool
nothing Maybe a
Nothing = Bool
True
nothing Maybe a
_ = Bool
False

buildnl :: LNode LName -> NameLayout
buildnl :: LNode String -> NameLayout
buildnl LNode String
x = MLNode String -> NameLayout
NL (Maybe LayoutRequest
forall a. Maybe a
Nothing,LNode String
x)
deNL :: NameLayout -> MLNode String
deNL (NL MLNode String
x) = MLNode String
x

leafReq :: LayoutRequest -> MLNode a
leafReq :: LayoutRequest -> MLNode a
leafReq LayoutRequest
req = (LayoutRequest -> Maybe LayoutRequest
forall a. a -> Maybe a
Just LayoutRequest
req,LLeaf a -> LNode a
forall a. LLeaf a -> LNode a
LLeaf (LLeaf a -> LNode a) -> LLeaf a -> LNode a
forall a b. (a -> b) -> a -> b
$ LayoutRequest -> LLeaf a
forall a. LayoutRequest -> LLeaf a
Req (LayoutRequest -> LLeaf a) -> LayoutRequest -> LLeaf a
forall a b. (a -> b) -> a -> b
$ LayoutRequest
req)

listNF :: (Eq a, Show a) => [(a, F b c)] -> F (a, b) (a, c)  
listNF :: [(a, F b c)] -> F (a, b) (a, c)
listNF [(a, F b c)]
fs = [(a, F b c)] -> F (a, b) (a, c)
forall a b c. Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF [(a
t, String -> F b c -> F b c
forall a b. String -> F a b -> F a b
nameF (a -> String
forall a. Show a => a -> String
show a
t) F b c
f) | (a
t, F b c
f) <- [(a, F b c)]
fs]

-- The main layout function
nameLayoutF :: NameLayout -> F a b -> F a b
nameLayoutF :: NameLayout -> F a b -> F a b
nameLayoutF (NL MLNode String
ltree) (F FSP a b
fsp) =
    let layoutSP :: SP
  (Either (FCommand a) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (FCommand a))
layoutSP =
            Int
-> [(String, Path)]
-> Cont
     (SP
        (Either (FCommand a) (Message (Path, FResponse) b))
        (Either (Message (Path, FResponse) b) (FCommand a)))
     [(String, Path)]
forall a b c.
Int
-> [(String, Path)]
-> Cont (SP (Either (FCommand a) b) c) [(String, Path)]
getAllPNames (MLNode String -> Int
forall a. MLNode a -> Int
countLNames MLNode String
ltree) [] Cont
  (SP
     (Either (FCommand a) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (FCommand a)))
  [(String, Path)]
-> Cont
     (SP
        (Either (FCommand a) (Message (Path, FResponse) b))
        (Either (Message (Path, FResponse) b) (FCommand a)))
     [(String, Path)]
forall a b. (a -> b) -> a -> b
$ \[(String, Path)]
pnames ->
            let ([(Path, NPath)]
pathTable, MLNode Path
ltree') = [(String, Path)]
-> NPath -> MLNode String -> ([(Path, NPath)], MLNode Path)
rebuildTree [(String, Path)]
pnames [] MLNode String
ltree
	    in [(Path, NPath)]
-> MLNode Path
-> SP
     (Either (FCommand a) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (FCommand a))
forall (t :: * -> *) b b.
Foldable t =>
t (Path, NPath)
-> MLNode Path
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
lSP [(Path, NPath)]
pathTable MLNode Path
ltree'
        lSP :: t (Path, NPath)
-> MLNode Path
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
lSP t (Path, NPath)
pt MLNode Path
ltree = 
            let same :: SP
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
same = t (Path, NPath)
-> MLNode Path
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
lSP t (Path, NPath)
pt MLNode Path
ltree in
            Cont
  (SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either
        (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
forall a b. Cont (SP a b) a
getSP Cont
  (SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either
        (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
-> Cont
     (SP
        (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
        (Either
           (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
forall a b. (a -> b) -> a -> b
$ \Either (Message (Path, FRequest) b) (Message (Path, FResponse) b)
msg ->
	    case Either (Message (Path, FRequest) b) (Message (Path, FResponse) b)
msg of
	      -- A message from the fudget
	      Left (Low (Path
path, LCmd (LayoutRequest LayoutRequest
lr))) ->
		  String
-> LayoutRequest
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a1 a2. Show a1 => String -> a1 -> a2 -> a2
ctrace String
"nameLayoutF" LayoutRequest
lr (SP
   (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
   (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
 -> SP
      (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
      (Either
         (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a b. (a -> b) -> a -> b
$
		  let ltree' :: MLNode Path
ltree' = Path -> Maybe NPath -> MLNode Path -> LayoutRequest -> MLNode Path
updateTree Path
path (t (Path, NPath) -> Path -> Maybe NPath
forall (t :: * -> *) b.
Foldable t =>
t (Path, b) -> Path -> Maybe b
pathlookup t (Path, NPath)
pt Path
path) MLNode Path
ltree LayoutRequest
lr
		  in case MLNode Path
ltree' of 
			(Just LayoutRequest
lreq, LNode Path
_) -> --trace (show ltree') $
			    Either (Message (Path, FResponse) b) (Message (Path, FRequest) b)
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall b a. b -> SP a b -> SP a b
putSP (Message (Path, FRequest) b
-> Either
     (Message (Path, FResponse) b) (Message (Path, FRequest) b)
forall a b. b -> Either a b
Right ((Path, FRequest) -> Message (Path, FRequest) b
forall a b. a -> Message a b
Low ([], LayoutRequest -> FRequest
layoutRequestCmd LayoutRequest
lreq))) (SP
   (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
   (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
 -> SP
      (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
      (Either
         (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a b. (a -> b) -> a -> b
$
			    t (Path, NPath)
-> MLNode Path
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
lSP t (Path, NPath)
pt MLNode Path
ltree'
			MLNode Path
_ -> t (Path, NPath)
-> MLNode Path
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
lSP t (Path, NPath)
pt MLNode Path
ltree'
	      Left Message (Path, FRequest) b
x -> Either (Message (Path, FResponse) b) (Message (Path, FRequest) b)
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall b a. b -> SP a b -> SP a b
putSP (Message (Path, FRequest) b
-> Either
     (Message (Path, FResponse) b) (Message (Path, FRequest) b)
forall a b. b -> Either a b
Right Message (Path, FRequest) b
x) (SP
   (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
   (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
 -> SP
      (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
      (Either
         (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a b. (a -> b) -> a -> b
$ SP
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
same
	      -- A message to the fudget
	      Right (Low (Path
path, LEvt (LayoutPlace Rect
r))) ->
		  [Either (Message (Path, FResponse) b) (Message (Path, FRequest) b)]
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall b a. [b] -> SP a b -> SP a b
putsSP (((Path, FResponse)
 -> Either
      (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> [(Path, FResponse)]
-> [Either
      (Message (Path, FResponse) b) (Message (Path, FRequest) b)]
forall a b. (a -> b) -> [a] -> [b]
map (Message (Path, FResponse) b
-> Either
     (Message (Path, FResponse) b) (Message (Path, FRequest) b)
forall a b. a -> Either a b
Left(Message (Path, FResponse) b
 -> Either
      (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> ((Path, FResponse) -> Message (Path, FResponse) b)
-> (Path, FResponse)
-> Either
     (Message (Path, FResponse) b) (Message (Path, FRequest) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path, FResponse) -> Message (Path, FResponse) b
forall a b. a -> Message a b
Low) ([(Path, FResponse)]
 -> [Either
       (Message (Path, FResponse) b) (Message (Path, FRequest) b)])
-> [(Path, FResponse)]
-> [Either
      (Message (Path, FResponse) b) (Message (Path, FRequest) b)]
forall a b. (a -> b) -> a -> b
$ Rect -> MLNode Path -> [(Path, FResponse)]
traverseTree Rect
r MLNode Path
ltree) (SP
   (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
   (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
 -> SP
      (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
      (Either
         (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a b. (a -> b) -> a -> b
$ SP
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
same
	      Right Message (Path, FResponse) b
x -> Either (Message (Path, FResponse) b) (Message (Path, FRequest) b)
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall b a. b -> SP a b -> SP a b
putSP (Message (Path, FResponse) b
-> Either
     (Message (Path, FResponse) b) (Message (Path, FRequest) b)
forall a b. a -> Either a b
Left Message (Path, FResponse) b
x) (SP
   (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
   (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
 -> SP
      (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
      (Either
         (Message (Path, FResponse) b) (Message (Path, FRequest) b)))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
-> SP
     (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
     (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
forall a b. (a -> b) -> a -> b
$ SP
  (Either (Message (Path, FRequest) b) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (Message (Path, FRequest) b))
same
    in F a b -> F a b -> F a b
forall c ho. F c ho -> F c ho -> F c ho
parF F a b
forall hi ho. F hi ho
nullF (F a b -> F a b) -> F a b -> F a b
forall a b. (a -> b) -> a -> b
$ FSP a b -> F a b
forall hi ho. FSP hi ho -> F hi ho
F{-ff-} (FSP a b -> F a b) -> FSP a b -> F a b
forall a b. (a -> b) -> a -> b
$ SP
  (Either (FCommand b) (Message (Path, FResponse) a))
  (Either (Message (Path, FResponse) a) (FCommand b))
-> FSP a b -> FSP a b
forall a1 a2 a3 b.
SP (Either a1 a2) (Either a3 b) -> SP a3 a1 -> SP a2 b
loopThroughRightSP SP
  (Either (FCommand b) (Message (Path, FResponse) a))
  (Either (Message (Path, FResponse) a) (FCommand b))
forall a b.
SP
  (Either (FCommand a) (Message (Path, FResponse) b))
  (Either (Message (Path, FResponse) b) (FCommand a))
layoutSP FSP a b
fsp
--  fix for autolayout

-----------------------------------------------------------------------------------
-- Local functions

-- Counts the number of named leafs in a layout structure
countLNames :: MLNode a -> Int
countLNames :: MLNode a -> Int
countLNames (Maybe LayoutRequest
_, LLeaf (Name a
_)) = Int
1
countLNames (Maybe LayoutRequest
_, LLeaf LLeaf a
_) = Int
0
countLNames (Maybe LayoutRequest
_, LNode Int
_ Placer
_ Maybe (Rect -> [Rect])
_ [MLNode a]
ns) = NPath -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((MLNode a -> Int) -> [MLNode a] -> NPath
forall a b. (a -> b) -> [a] -> [b]
map MLNode a -> Int
forall a. MLNode a -> Int
countLNames [MLNode a]
ns)

-- Traverses the layout structure, returning a mapping from leaf names to paths
getAllPNames :: Int -> [(LName, Path)] -> 
	     Cont (SP (Either (FCommand a) b) c) [(LName,Path)]
getAllPNames :: Int
-> [(String, Path)]
-> Cont (SP (Either (FCommand a) b) c) [(String, Path)]
getAllPNames Int
0 [(String, Path)]
pnames [(String, Path)] -> SP (Either (FCommand a) b) c
c = [(String, Path)] -> SP (Either (FCommand a) b) c
c [(String, Path)]
pnames
getAllPNames Int
n [(String, Path)]
pnames [(String, Path)] -> SP (Either (FCommand a) b) c
c =
    (Either (FCommand a) b -> Maybe (String, Path))
-> ((String, Path) -> SP (Either (FCommand a) b) c)
-> SP (Either (FCommand a) b) c
forall a t b. (a -> Maybe t) -> (t -> SP a b) -> SP a b
waitForSP Either (FCommand a) b -> Maybe (String, Path)
forall b b b.
Either (Message (b, FRequest) b) b -> Maybe (String, b)
layoutName (((String, Path) -> SP (Either (FCommand a) b) c)
 -> SP (Either (FCommand a) b) c)
-> ((String, Path) -> SP (Either (FCommand a) b) c)
-> SP (Either (FCommand a) b) c
forall a b. (a -> b) -> a -> b
$ \(String, Path)
pname ->
    Int
-> [(String, Path)]
-> Cont (SP (Either (FCommand a) b) c) [(String, Path)]
forall a b c.
Int
-> [(String, Path)]
-> Cont (SP (Either (FCommand a) b) c) [(String, Path)]
getAllPNames (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ((String, Path)
pname(String, Path) -> [(String, Path)] -> [(String, Path)]
forall a. a -> [a] -> [a]
:[(String, Path)]
pnames) [(String, Path)] -> SP (Either (FCommand a) b) c
c
    where layoutName :: Either (Message (b, FRequest) b) b -> Maybe (String, b)
layoutName (Left (Low (b
path, LCmd (LayoutName String
name)))) = 
              (String, b) -> Maybe (String, b)
forall a. a -> Maybe a
Just(String
name, b
path)
          layoutName Either (Message (b, FRequest) b) b
_ = Maybe (String, b)
forall a. Maybe a
Nothing

-- Rebuilds the layout structure. 
-- Returns also a mapping from ordinary paths to number paths.
rebuildTree :: [(LName, Path)] -> NPath -> MLNode LName ->
               ([(Path, NPath)], MLNode Path)
rebuildTree :: [(String, Path)]
-> NPath -> MLNode String -> ([(Path, NPath)], MLNode Path)
rebuildTree [(String, Path)]
pnames NPath
np (Maybe LayoutRequest
_, LLeaf (Name String
name)) = 
    case String -> [(String, Path)] -> Maybe Path
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, Path)]
pnames of
        Maybe Path
Nothing -> String -> ([(Path, NPath)], MLNode Path)
forall a. HasCallStack => String -> a
error (String
"Couldn't find name "String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ 
			  String
" in (name, path) table.")
	Just Path
path -> ([(Path
path, NPath
np)], (Maybe LayoutRequest
forall a. Maybe a
Nothing, LLeaf Path -> LNode Path
forall a. LLeaf a -> LNode a
LLeaf (LLeaf Path -> LNode Path) -> LLeaf Path -> LNode Path
forall a b. (a -> b) -> a -> b
$ Path -> LLeaf Path
forall a. a -> LLeaf a
Name Path
path))
rebuildTree [(String, Path)]
pnames NPath
np (Maybe LayoutRequest
_, (LLeaf (Req LayoutRequest
r))) = ([],(LayoutRequest -> Maybe LayoutRequest
forall a. a -> Maybe a
Just LayoutRequest
r, (LLeaf Path -> LNode Path
forall a. LLeaf a -> LNode a
LLeaf (LayoutRequest -> LLeaf Path
forall a. LayoutRequest -> LLeaf a
Req LayoutRequest
r))))
rebuildTree [(String, Path)]
pnames NPath
np (Maybe LayoutRequest
_, LNode Int
c Placer
lter Maybe (Rect -> [Rect])
Nothing [MLNode String]
ns) =
    ([[(Path, NPath)]] -> [(Path, NPath)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Path, NPath)]]
ts, (Maybe LayoutRequest
forall a. Maybe a
Nothing, Int
-> Placer -> Maybe (Rect -> [Rect]) -> [MLNode Path] -> LNode Path
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode Int
c Placer
lter Maybe (Rect -> [Rect])
forall a. Maybe a
Nothing [MLNode Path]
ns'))
    where ([[(Path, NPath)]]
ts, [MLNode Path]
ns') = [([(Path, NPath)], MLNode Path)]
-> ([[(Path, NPath)]], [MLNode Path])
forall a b. [(a, b)] -> ([a], [b])
unzip ((NPath -> MLNode String -> ([(Path, NPath)], MLNode Path))
-> [NPath] -> [MLNode String] -> [([(Path, NPath)], MLNode Path)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([(String, Path)]
-> NPath -> MLNode String -> ([(Path, NPath)], MLNode Path)
rebuildTree [(String, Path)]
pnames) 
                                     ((Int -> NPath) -> NPath -> [NPath]
forall a b. (a -> b) -> [a] -> [b]
map ((NPath
npNPath -> NPath -> NPath
forall a. [a] -> [a] -> [a]
++) (NPath -> NPath) -> (Int -> NPath) -> Int -> NPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> NPath -> NPath
forall a. a -> [a] -> [a]
:[])) [Int
1..]) [MLNode String]
ns)


-- Inserts layout requests in the layout structure.
-- Trigged by some fudget emitting a layout request
updateTree :: Path -> 
              Maybe NPath -> 
	      MLNode Path -> 
	      LayoutRequest -> 
              MLNode Path
updateTree :: Path -> Maybe NPath -> MLNode Path -> LayoutRequest -> MLNode Path
updateTree Path
path Maybe NPath
Nothing MLNode Path
_ LayoutRequest
lr = 
    String -> MLNode Path
forall a. HasCallStack => String -> a
error (String
"Hmmm. Couldn't find path " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
path String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
"in updateTree\nSomeone has probably forgotten to name a fudget.")
updateTree Path
path (Just NPath
npath) MLNode Path
lo LayoutRequest
lr = (Bool, MLNode Path) -> MLNode Path
forall a b. (a, b) -> b
snd ((Bool, MLNode Path) -> MLNode Path)
-> (Bool, MLNode Path) -> MLNode Path
forall a b. (a -> b) -> a -> b
$ NPath -> MLNode Path -> LayoutRequest -> (Bool, MLNode Path)
upd NPath
npath MLNode Path
lo LayoutRequest
lr
    where upd :: NPath -> MLNode Path -> LayoutRequest -> (Bool, MLNode Path)
upd NPath
_ (Maybe LayoutRequest
mlr, LLeaf (Name Path
p)) LayoutRequest
lr = 
                 (Maybe LayoutRequest -> Bool
forall a. Maybe a -> Bool
nothing Maybe LayoutRequest
mlr, (LayoutRequest -> Maybe LayoutRequest
forall a. a -> Maybe a
Just LayoutRequest
lr, LLeaf Path -> LNode Path
forall a. LLeaf a -> LNode a
LLeaf (Path -> LLeaf Path
forall a. a -> LLeaf a
Name Path
path)))
          upd (Int
n:NPath
np) (Maybe LayoutRequest
mlr, LNode Int
c lter :: Placer
lter@(P Placer1
lter') Maybe (Rect -> [Rect])
mr [MLNode Path]
ns) LayoutRequest
lr =
	      let ([MLNode Path]
before, MLNode Path
this:[MLNode Path]
after) = Int -> [MLNode Path] -> ([MLNode Path], [MLNode Path])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [MLNode Path]
ns
	          (Bool
ready, MLNode Path
child) = NPath -> MLNode Path -> LayoutRequest -> (Bool, MLNode Path)
upd NPath
np MLNode Path
this LayoutRequest
lr
	          c' :: Int
c' = if Bool
ready then Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
0 else Int
c
		  ns' :: [MLNode Path]
ns' = [MLNode Path]
before [MLNode Path] -> [MLNode Path] -> [MLNode Path]
forall a. [a] -> [a] -> [a]
++ [MLNode Path
child] [MLNode Path] -> [MLNode Path] -> [MLNode Path]
forall a. [a] -> [a] -> [a]
++ [MLNode Path]
after
	      in if Int
c' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
	             let (LayoutRequest
lreq, Rect -> [Rect]
rectf) = Placer1
lter' ((MLNode Path -> LayoutRequest) -> [MLNode Path] -> [LayoutRequest]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe LayoutRequest -> LayoutRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe LayoutRequest -> LayoutRequest)
-> (MLNode Path -> Maybe LayoutRequest)
-> MLNode Path
-> LayoutRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLNode Path -> Maybe LayoutRequest
forall a b. (a, b) -> a
fst) [MLNode Path]
ns')
		     in (Maybe LayoutRequest -> Bool
forall a. Maybe a -> Bool
nothing Maybe LayoutRequest
mlr, 
		         (LayoutRequest -> Maybe LayoutRequest
forall a. a -> Maybe a
Just LayoutRequest
lreq, Int
-> Placer -> Maybe (Rect -> [Rect]) -> [MLNode Path] -> LNode Path
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode Int
c' Placer
lter ((Rect -> [Rect]) -> Maybe (Rect -> [Rect])
forall a. a -> Maybe a
Just Rect -> [Rect]
rectf) [MLNode Path]
ns'))
		 else
		     (Bool
False, (Maybe LayoutRequest
forall a. Maybe a
Nothing, Int
-> Placer -> Maybe (Rect -> [Rect]) -> [MLNode Path] -> LNode Path
forall a.
Int -> Placer -> Maybe (Rect -> [Rect]) -> [MLNode a] -> LNode a
LNode Int
c' Placer
lter Maybe (Rect -> [Rect])
mr [MLNode Path]
ns'))
          upd NPath
_ MLNode Path
othernode LayoutRequest
_ = (Bool
False,MLNode Path
othernode)

-- We have got a rectangle. Emit commands to all subfudgets saying how large
-- they should be. 
traverseTree :: Rect -> MLNode Path -> [TEvent]
traverseTree :: Rect -> MLNode Path -> [(Path, FResponse)]
traverseTree Rect
r (Maybe LayoutRequest
_, LLeaf (Name Path
path)) = [(Path
path, LayoutResponse -> FResponse
LEvt (LayoutResponse -> FResponse) -> LayoutResponse -> FResponse
forall a b. (a -> b) -> a -> b
$ Rect -> LayoutResponse
LayoutPlace Rect
r)]
traverseTree Rect
r (Maybe LayoutRequest
_, LLeaf LLeaf Path
_) = []
traverseTree Rect
r (Maybe LayoutRequest
_, LNode Int
_ Placer
_ (Just Rect -> [Rect]
rectf) [MLNode Path]
ns) =
    [[(Path, FResponse)]] -> [(Path, FResponse)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Rect -> MLNode Path -> [(Path, FResponse)])
-> [Rect] -> [MLNode Path] -> [[(Path, FResponse)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Rect -> MLNode Path -> [(Path, FResponse)]
traverseTree (Rect -> [Rect]
rectf Rect
r) [MLNode Path]
ns) 

pathlookup :: t (Path, b) -> Path -> Maybe b
pathlookup t (Path, b)
table Path
p = (Path -> Bool) -> t (Path, b) -> Maybe b
forall (t :: * -> *) a b.
Foldable t =>
(a -> Bool) -> t (a, b) -> Maybe b
plookup ((Path -> Path -> Bool) -> Path -> Path -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Path -> Path -> Bool
subPath Path
p) t (Path, b)
table