module NameLayout(LName(..),placeNL,spaceNL,modNL,marginNL,sepNL,hvAlignNL,marginHVAlignNL,nullNL,hBoxNL,hBoxNL',vBoxNL, vBoxNL',leafNL, NameLayout, nameF,
listNF, nameLayoutF) where
import LayoutRequest
import NullF
import Spops
import FRequest
import EitherUtils(plookup)
import Data.Maybe(fromJust)
import Fudget
import Path
import Geometry
import Placers
import Spacers
import ListF
import Loopthrough
import Cont
import AlignP
import Utils
import Maptrace
import AutoLayout
import ParF
type LName = String
newtype NameLayout = NL (MLNode LName)
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]
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
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]
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
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
_) ->
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
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 (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
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)
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
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)
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)
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