{-# LANGUAGE CPP #-}
module AutoLayout(autoLayoutF,autoLayoutF',nowait) where
import LayoutRequest(LayoutMessage(..),LayoutResponse(..),LayoutRequest(minsize),LayoutHint,Spacer,Placer(..),Placer2,unS)
import LayoutDoNow
import PathTree hiding (pos)
import Geometry(Rect)
import Fudget
import NullF(getK,putK,putsK)
import Loops(loopThroughRightF)
import UserLayoutF
import FRequest
import Direction
import IoF(ioF)
import CmdLineEnv(argFlag)
import Data.Maybe(isJust)
import HbcUtils(apFst,apSnd)
import Spacers(idS,compS,spacerP)
import AutoPlacer(autoP)
import SizingF
#ifdef __NHC__
import qualified Sizing
#else
import qualified Sizing(Sizing(..))
#endif
import StdIoUtil(echoStderrK)
debugK :: String -> K hi ho -> K hi ho
debugK :: String -> K hi ho -> K hi ho
debugK =
if Bool
dbg
then \ String
msg -> String -> K hi ho -> K hi ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> f b ho -> f b ho
echoStderrK (String
"AutoLayout: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg)
else (K hi ho -> K hi ho) -> String -> K hi ho -> K hi ho
forall a b. a -> b -> a
const K hi ho -> K hi ho
forall a. a -> a
id
where
dbg :: Bool
dbg = String -> Bool -> Bool
argFlag String
"ad" Bool
False
type LayoutTree = PathTree LayoutInfo
mapLT :: (LeafInfo -> LeafInfo)
-> (NodeInfo -> NodeInfo)
-> PathTree LayoutInfo
-> PathTree LayoutInfo
mapLT LeafInfo -> LeafInfo
lf NodeInfo -> NodeInfo
nf = (LayoutInfo -> LayoutInfo)
-> PathTree LayoutInfo -> PathTree LayoutInfo
forall t n. (t -> n) -> PathTree t -> PathTree n
mapPathTree ((LeafInfo -> LeafInfo)
-> (NodeInfo -> NodeInfo) -> LayoutInfo -> LayoutInfo
mapLayoutInfo LeafInfo -> LeafInfo
lf NodeInfo -> NodeInfo
nf)
top0 :: PathTree LayoutInfo
top0 = LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
forall n. n -> PathTree n -> PathTree n -> PathTree n
Node (NodeInfo -> LayoutInfo
NodeInfo (String -> Maybe String
forall a. a -> Maybe a
Just String
"top",PlacerInfo
NoPlacerInfo)) PathTree LayoutInfo
forall n. PathTree n
Tip PathTree LayoutInfo
forall n. PathTree n
Tip
data LayoutInfo
= NodeInfo NodeInfo
| LeafInfo LeafInfo
deriving (Int -> LayoutInfo -> String -> String
[LayoutInfo] -> String -> String
LayoutInfo -> String
(Int -> LayoutInfo -> String -> String)
-> (LayoutInfo -> String)
-> ([LayoutInfo] -> String -> String)
-> Show LayoutInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LayoutInfo] -> String -> String
$cshowList :: [LayoutInfo] -> String -> String
show :: LayoutInfo -> String
$cshow :: LayoutInfo -> String
showsPrec :: Int -> LayoutInfo -> String -> String
$cshowsPrec :: Int -> LayoutInfo -> String -> String
Show)
mapLayoutInfo :: (LeafInfo -> LeafInfo)
-> (NodeInfo -> NodeInfo) -> LayoutInfo -> LayoutInfo
mapLayoutInfo LeafInfo -> LeafInfo
lf NodeInfo -> NodeInfo
nf LayoutInfo
n = case LayoutInfo
n of
NodeInfo NodeInfo
n -> NodeInfo -> LayoutInfo
NodeInfo (NodeInfo -> NodeInfo
nf NodeInfo
n)
LeafInfo LeafInfo
l -> LeafInfo -> LayoutInfo
LeafInfo (LeafInfo -> LeafInfo
lf LeafInfo
l)
type LeafInfo = (LayoutRequest,Maybe Rect)
type NodeInfo = ((Maybe LayoutHint), PlacerInfo)
data PlacerInfo =
NoPlacerInfo |
JustSpacer Spacer |
SpacerPlacer Spacer Placer (Maybe Placer2) Spacer
deriving (Int -> PlacerInfo -> String -> String
[PlacerInfo] -> String -> String
PlacerInfo -> String
(Int -> PlacerInfo -> String -> String)
-> (PlacerInfo -> String)
-> ([PlacerInfo] -> String -> String)
-> Show PlacerInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PlacerInfo] -> String -> String
$cshowList :: [PlacerInfo] -> String -> String
show :: PlacerInfo -> String
$cshow :: PlacerInfo -> String
showsPrec :: Int -> PlacerInfo -> String -> String
$cshowsPrec :: Int -> PlacerInfo -> String -> String
Show)
data PlacementState
= Placed (Rect->Rect)
| Waiting
deriving (Int -> PlacementState -> String -> String
[PlacementState] -> String -> String
PlacementState -> String
(Int -> PlacementState -> String -> String)
-> (PlacementState -> String)
-> ([PlacementState] -> String -> String)
-> Show PlacementState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PlacementState] -> String -> String
$cshowList :: [PlacementState] -> String -> String
show :: PlacementState -> String
$cshow :: PlacementState -> String
showsPrec :: Int -> PlacementState -> String -> String
$cshowsPrec :: Int -> PlacementState -> String -> String
Show)
autoLayoutF :: F a b -> F a b
autoLayoutF = Bool -> Sizing -> F a b -> F a b
forall a b. Bool -> Sizing -> F a b -> F a b
autoLayoutF' Bool
nowait Sizing
Sizing.Dynamic
nowait :: Bool
nowait = String -> Bool -> Bool
argFlag String
"nowait" Bool
False
autoLayoutF' :: Bool -> Sizing.Sizing -> F a b -> F a b
autoLayoutF' :: Bool -> Sizing -> F a b -> F a b
autoLayoutF' Bool
nowait Sizing
sizing F a b
fud =
F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
-> F (Path, LayoutMessage) (Path, Rect) -> F a b
forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF
(F a b -> F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
forall a b.
F a b -> F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
userLayoutF (F a b -> F a b
forall hi ho. F hi ho -> F hi ho
layoutDoNow F a b
fud))
( (Sizing
-> F (Path, LayoutMessage) (Path, Rect)
-> F (Path, LayoutMessage) (Path, Rect)
forall i o. Sizing -> F i o -> F i o
sizingF Sizing
sizing (K (Path, LayoutMessage) (Path, Rect)
-> F (Path, LayoutMessage) (Path, Rect)
forall a b. K a b -> F a b
ioF (PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK0 PlacementState
state0 PathTree LayoutInfo
top0))))
where
state0 :: PlacementState
state0 = if Bool
nowait then (Rect -> Rect) -> PlacementState
Placed Rect -> Rect
forall a. a -> a
id else PlacementState
Waiting
autoLayoutMgrK0 :: PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK0 PlacementState
pstate PathTree LayoutInfo
ltree =
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK String
"autoLayoutMgrK" (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK PlacementState
pstate PathTree LayoutInfo
ltree
autoLayoutMgrK :: PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK PlacementState
pstate PathTree LayoutInfo
ltree =
Cont
(K (Path, LayoutMessage) (Path, Rect))
(KEvent (Path, LayoutMessage))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont
(K (Path, LayoutMessage) (Path, Rect))
(KEvent (Path, LayoutMessage))
-> Cont
(K (Path, LayoutMessage) (Path, Rect))
(KEvent (Path, LayoutMessage))
forall a b. (a -> b) -> a -> b
$ \ KEvent (Path, LayoutMessage)
msg ->
case KEvent (Path, LayoutMessage)
msg of
High (Path
path,LayoutMessage
layoutmsg) ->
case LayoutMessage
layoutmsg of
LayoutMessage
LayoutDoNow ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK String
"LayoutDoNow" (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (PathTree LayoutInfo -> String
forall a. Show a => a -> String
show PathTree LayoutInfo
ltree) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newPlace PathTree LayoutInfo
ltree
LayoutRequest LayoutRequest
req ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Layout "String -> String -> String
forall a. [a] -> [a] -> [a]
++Size -> String
forall a. Show a => a -> String
show (LayoutRequest -> Size
minsize LayoutRequest
req)) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (PathTree LayoutInfo -> String
forall a. Show a => a -> String
show PathTree LayoutInfo
ltree') (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
changePlacement PathTree LayoutInfo
ltree'
where ltree' :: PathTree LayoutInfo
ltree' = Path -> LayoutRequest -> PathTree LayoutInfo -> PathTree LayoutInfo
updateLeaf Path
path LayoutRequest
req PathTree LayoutInfo
ltree''
ltree'' :: PathTree LayoutInfo
ltree'' = if PathTree LayoutInfo -> Path -> Bool
forall n. Show n => PathTree n -> Path -> Bool
newBox PathTree LayoutInfo
ltree Path
path
then PathTree LayoutInfo -> PathTree LayoutInfo
forgetPlaces PathTree LayoutInfo
ltree
else PathTree LayoutInfo
ltree
LayoutHint String
hint ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutHint "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
hint) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
(NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (String -> NodeInfo -> NodeInfo
forall a a. a -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertHint String
hint)
LayoutPlacer Placer
placer ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutPlacer ...") (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
(NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (Placer -> NodeInfo -> NodeInfo
forall a a. Placer -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertPlacer Placer
placer)
LayoutSpacer Spacer
spacer ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutSpacer ...") (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
(NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (Spacer -> NodeInfo -> NodeInfo
forall a. Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
insertSpacer Spacer
spacer)
LayoutReplaceSpacer Spacer
spacer ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutReplaceSpacer ...") (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
(NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
replnode (Spacer -> NodeInfo -> NodeInfo
forall a. Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
replaceSpacer Spacer
spacer)
LayoutReplacePlacer Placer
placer ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutReplacePlacer ...") (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
(NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
replnode (Placer -> NodeInfo -> NodeInfo
forall a. Placer -> (a, PlacerInfo) -> (a, PlacerInfo)
replacePlacer Placer
placer)
LayoutMessage
LayoutDestroy ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK ((Path, PathTree LayoutInfo) -> String
forall a. Show a => a -> String
show (Path
path,PathTree LayoutInfo
ltree) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LayoutDestroy") (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
if PathTree LayoutInfo -> Path -> Bool
forall n. Show n => PathTree n -> Path -> Bool
newBox PathTree LayoutInfo
ltree Path
path then String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (String
"not in tree") K (Path, LayoutMessage) (Path, Rect)
same else
PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
changePlacement (PathTree LayoutInfo -> PathTree LayoutInfo
forgetPlaces (Path -> PathTree LayoutInfo -> PathTree LayoutInfo
pruneLTree Path
path PathTree LayoutInfo
ltree))
LayoutMakeVisible Rect
_ (Maybe Alignment, Maybe Alignment)
_ -> KCommand (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (FRequest -> KCommand (Path, Rect)
forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd LayoutMessage
layoutmsg)) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$ K (Path, LayoutMessage) (Path, Rect)
same
LayoutScrollStep Int
_ -> KCommand (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (FRequest -> KCommand (Path, Rect)
forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd LayoutMessage
layoutmsg)) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$ K (Path, LayoutMessage) (Path, Rect)
same
LayoutMessage
_ -> K (Path, LayoutMessage) (Path, Rect)
same
where updnode :: (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode NodeInfo -> NodeInfo
u = PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newTree (Path
-> (NodeInfo -> NodeInfo)
-> PathTree LayoutInfo
-> PathTree LayoutInfo
updateLNode Path
path NodeInfo -> NodeInfo
u PathTree LayoutInfo
ltree)
replnode :: (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
replnode NodeInfo -> NodeInfo
u = PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
changePlacement (PathTree LayoutInfo -> PathTree LayoutInfo
forgetPlaces (Path
-> (NodeInfo -> NodeInfo)
-> PathTree LayoutInfo
-> PathTree LayoutInfo
updateLNode Path
path NodeInfo -> NodeInfo
u PathTree LayoutInfo
ltree))
Low (LEvt (LayoutPlace Rect
rect)) ->
String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK (String
"splitting 1 Place into "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show ([(Path, Rect)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Path, Rect)]
msgs)) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
[KCommand (Path, Rect)]
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall b a. [KCommand b] -> K a b -> K a b
putsK (((Path, Rect) -> KCommand (Path, Rect))
-> [(Path, Rect)] -> [KCommand (Path, Rect)]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Rect) -> KCommand (Path, Rect)
forall a b. b -> Message a b
High [(Path, Rect)]
msgs) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newTree PathTree LayoutInfo
ltree'
where (PathTree LayoutInfo
ltree',[(Path, Rect)]
msgs) = Rect
-> PathTree LayoutInfo -> (PathTree LayoutInfo, [(Path, Rect)])
doLayout (Rect -> Rect
s2 Rect
rect) PathTree LayoutInfo
ltree
s2 :: Rect -> Rect
s2 = case PlacementState
pstate of
Placed s2 -> Rect -> Rect
s2
PlacementState
_ -> Rect -> Rect
forall a. a -> a
id
Low FResponse
_ -> String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK String
"Ignored low level msg" K (Path, LayoutMessage) (Path, Rect)
same
where
same :: K (Path, LayoutMessage) (Path, Rect)
same = PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK PlacementState
pstate PathTree LayoutInfo
ltree
newTree :: PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newTree PathTree LayoutInfo
t' = PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newState PlacementState
pstate PathTree LayoutInfo
t'
newState :: PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newState PlacementState
p' PathTree LayoutInfo
t' = PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK PlacementState
p' PathTree LayoutInfo
t'
changePlacement :: PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
changePlacement PathTree LayoutInfo
ltree' =
case PlacementState
pstate of
Placed _ -> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newPlace PathTree LayoutInfo
ltree'
PlacementState
Waiting -> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newTree PathTree LayoutInfo
ltree'
newPlace :: PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newPlace PathTree LayoutInfo
ltree =
let ltree' :: PathTree LayoutInfo
ltree' = PathTree LayoutInfo -> PathTree LayoutInfo
chooseLayout PathTree LayoutInfo
ltree
in case PathTree LayoutInfo -> ([Spacer2], PathTree LayoutInfo)
collectReqs PathTree LayoutInfo
ltree' of
([],PathTree LayoutInfo
_) -> String
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall hi ho. String -> K hi ho -> K hi ho
debugK String
"newPlace without any requests in ltree" K (Path, LayoutMessage) (Path, Rect)
same
((LayoutRequest
req,Rect -> Rect
s2):[Spacer2]
_,PathTree LayoutInfo
ltree2) ->
KCommand (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (FRequest -> KCommand (Path, Rect)
forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd LayoutRequest
req)) (K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect))
-> K (Path, LayoutMessage) (Path, Rect)
-> K (Path, LayoutMessage) (Path, Rect)
forall a b. (a -> b) -> a -> b
$
PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newState ((Rect -> Rect) -> PlacementState
Placed Rect -> Rect
s2) PathTree LayoutInfo
ltree2
updateLNode :: Path
-> (NodeInfo -> NodeInfo)
-> PathTree LayoutInfo
-> PathTree LayoutInfo
updateLNode Path
path NodeInfo -> NodeInfo
i PathTree LayoutInfo
t = (LayoutInfo -> LayoutInfo)
-> LayoutInfo
-> PathTree LayoutInfo
-> Path
-> (LayoutInfo -> LayoutInfo)
-> PathTree LayoutInfo
forall n.
(n -> n) -> n -> PathTree n -> Path -> (n -> n) -> PathTree n
updateNode LayoutInfo -> LayoutInfo
forall a. a -> a
id LayoutInfo
emptyNode PathTree LayoutInfo
t Path
path ((LayoutInfo -> LayoutInfo) -> PathTree LayoutInfo)
-> (LayoutInfo -> LayoutInfo) -> PathTree LayoutInfo
forall a b. (a -> b) -> a -> b
$
\(NodeInfo NodeInfo
ni) -> NodeInfo -> LayoutInfo
NodeInfo (NodeInfo -> NodeInfo
i NodeInfo
ni)
insertHint :: a -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertHint a
hint (a
_,PlacerInfo
pi) = (case PlacerInfo
pi of
SpacerPlacer Spacer
_ Placer
_ Maybe Placer2
_ Spacer
_ -> Maybe a
forall a. Maybe a
Nothing
PlacerInfo
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
hint,PlacerInfo
pi)
insertPlacer :: Placer -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertPlacer Placer
placer (a
hint,PlacerInfo
pi) = (Maybe a
forall a. Maybe a
Nothing,case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
idS Placer
placer Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
JustSpacer Spacer
s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
placer Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
_ Spacer
s2 -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer (Spacer
s1 Spacer -> Spacer -> Spacer
`compS` Spacer
s2) (Placer
p Placer -> Placer -> Placer
`compP` Placer
placer)
Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS)
where compP :: Placer -> Placer -> Placer
compP :: Placer -> Placer -> Placer
compP (P Placer1
p1) (P Placer1
p2) = Placer1 -> Placer
P (Placer1 -> Placer) -> Placer1 -> Placer
forall a b. (a -> b) -> a -> b
$ \ [LayoutRequest]
reqs ->
let (LayoutRequest
req1,Rect -> [Rect]
p1r) = Placer1
p1 [LayoutRequest
req2]
(LayoutRequest
req2,Rect -> [Rect]
p2r) = Placer1
p2 [LayoutRequest]
reqs
in (LayoutRequest
req1,Rect -> [Rect]
p2r(Rect -> [Rect]) -> (Rect -> Rect) -> Rect -> [Rect]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Rect] -> Rect
forall a. [a] -> a
head([Rect] -> Rect) -> (Rect -> [Rect]) -> Rect -> Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Rect -> [Rect]
p1r)
insertSpacer :: Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
insertSpacer Spacer
spacer (a
hint,PlacerInfo
pi) = (a
hint,case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> Spacer -> PlacerInfo
JustSpacer Spacer
spacer
JustSpacer Spacer
s -> Spacer -> PlacerInfo
JustSpacer (Spacer
s Spacer -> Spacer -> Spacer
`compS` Spacer
spacer)
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
p2 Spacer
s2 -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
p2 (Spacer
s2 Spacer -> Spacer -> Spacer
`compS` Spacer
spacer))
replaceSpacer :: Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
replaceSpacer Spacer
spacer (a
hint,PlacerInfo
pi) = (a
hint,PlacerInfo
pi')
where
pi' :: PlacerInfo
pi' = case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> Spacer -> PlacerInfo
JustSpacer Spacer
spacer
JustSpacer s -> Spacer -> PlacerInfo
JustSpacer Spacer
spacer
SpacerPlacer s1 p p2 s2 -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
spacer Placer
p Maybe Placer2
p2 Spacer
s2
replacePlacer :: Placer -> (a, PlacerInfo) -> (a, PlacerInfo)
replacePlacer Placer
placer (a
hint,PlacerInfo
pi) = (a
hint,PlacerInfo
pi')
where
pi' :: PlacerInfo
pi' = case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
idS Placer
placer Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
JustSpacer s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
placer Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
SpacerPlacer s1 p p2 s2 -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s1 Placer
placer Maybe Placer2
forall a. Maybe a
Nothing Spacer
s2
updateLeaf :: Path -> LayoutRequest -> PathTree LayoutInfo -> PathTree LayoutInfo
updateLeaf Path
path LayoutRequest
l PathTree LayoutInfo
t =
(LayoutInfo -> LayoutInfo)
-> LayoutInfo
-> PathTree LayoutInfo
-> Path
-> (LayoutInfo -> LayoutInfo)
-> PathTree LayoutInfo
forall n.
(n -> n) -> n -> PathTree n -> Path -> (n -> n) -> PathTree n
updateNode LayoutInfo -> LayoutInfo
invalid LayoutInfo
emptyNode PathTree LayoutInfo
t Path
path (LayoutInfo -> LayoutInfo -> LayoutInfo
forall a b. a -> b -> a
const (LeafInfo -> LayoutInfo
LeafInfo (LayoutRequest
l,Maybe Rect
forall a. Maybe a
Nothing)))
pruneLTree :: Path -> PathTree LayoutInfo -> PathTree LayoutInfo
pruneLTree Path
path PathTree LayoutInfo
t = (LayoutInfo -> LayoutInfo)
-> LayoutInfo -> PathTree LayoutInfo -> Path -> PathTree LayoutInfo
forall n. (n -> n) -> n -> PathTree n -> Path -> PathTree n
pruneTree LayoutInfo -> LayoutInfo
invalid LayoutInfo
emptyNode PathTree LayoutInfo
t Path
path
forgetPlaces :: PathTree LayoutInfo -> PathTree LayoutInfo
forgetPlaces = (LeafInfo -> LeafInfo)
-> (NodeInfo -> NodeInfo)
-> PathTree LayoutInfo
-> PathTree LayoutInfo
mapLT ((Maybe Rect -> Maybe Rect) -> LeafInfo -> LeafInfo
forall t b a. (t -> b) -> (a, t) -> (a, b)
apSnd (Maybe Rect -> Maybe Rect -> Maybe Rect
forall a b. a -> b -> a
const Maybe Rect
forall a. Maybe a
Nothing)) NodeInfo -> NodeInfo
forall a. a -> a
id
newBox :: PathTree n -> Path -> Bool
newBox PathTree n
x = (PathTree n -> Bool) -> Bool -> PathTree n -> Path -> Bool
forall n a2.
Show n =>
(PathTree n -> a2) -> a2 -> PathTree n -> Path -> a2
subTree (Bool -> PathTree n -> Bool
forall a b. a -> b -> a
const Bool
False) Bool
True PathTree n
x
invalid :: LayoutInfo -> LayoutInfo
invalid (NodeInfo NodeInfo
i) = NodeInfo -> LayoutInfo
NodeInfo (NodeInfo -> NodeInfo
forall a. (a, PlacerInfo) -> (a, PlacerInfo)
invalid' NodeInfo
i)
where
invalid' :: (a, PlacerInfo) -> (a, PlacerInfo)
invalid' (a
hi,SpacerPlacer Spacer
s Placer
p Maybe Placer2
p2 Spacer
s2) = (a
hi,Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
p Maybe Placer2
forall a. Maybe a
Nothing Spacer
s2)
invalid' (a, PlacerInfo)
ni = (a, PlacerInfo)
ni
emptyNode :: LayoutInfo
emptyNode = NodeInfo -> LayoutInfo
NodeInfo (Maybe String
forall a. Maybe a
Nothing,PlacerInfo
NoPlacerInfo)
hasPlacer :: (Maybe a, PlacerInfo) -> Bool
hasPlacer (Maybe a
Nothing,SpacerPlacer Spacer
_ Placer
_ Maybe Placer2
_ Spacer
_) = Bool
True
hasPlacer (Maybe a, PlacerInfo)
_ = Bool
False
chooseLayout :: PathTree LayoutInfo -> PathTree LayoutInfo
chooseLayout = ([()], PathTree LayoutInfo) -> PathTree LayoutInfo
forall a b. (a, b) -> b
snd (([()], PathTree LayoutInfo) -> PathTree LayoutInfo)
-> (PathTree LayoutInfo -> ([()], PathTree LayoutInfo))
-> PathTree LayoutInfo
-> PathTree LayoutInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> [()] -> LeafInfo -> (Bool, (), LeafInfo))
-> (Bool -> [()] -> NodeInfo -> (Bool, (), NodeInfo))
-> Bool
-> PathTree LayoutInfo
-> ([()], PathTree LayoutInfo)
forall t s.
(t -> [s] -> LeafInfo -> (t, s, LeafInfo))
-> (t -> [s] -> NodeInfo -> (t, s, NodeInfo))
-> t
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT Bool -> [()] -> LeafInfo -> (Bool, (), LeafInfo)
forall a p c. a -> p -> c -> (a, (), c)
lf Bool -> [()] -> NodeInfo -> (Bool, (), NodeInfo)
forall p a.
Bool
-> p -> (Maybe a, PlacerInfo) -> (Bool, (), (Maybe a, PlacerInfo))
nf Bool
False where
lf :: a -> p -> c -> (a, (), c)
lf a
strip p
_ c
i = (a
strip,(),c
i)
nf :: Bool
-> p -> (Maybe a, PlacerInfo) -> (Bool, (), (Maybe a, PlacerInfo))
nf Bool
strip p
_ (Maybe a, PlacerInfo)
n = (Bool
strip',(),(Maybe a, PlacerInfo)
n') where
strip' :: Bool
strip' = case (Maybe a, PlacerInfo)
n of
(Nothing,SpacerPlacer _ _ _ _) -> Bool
True
(Maybe a, PlacerInfo)
_ -> Bool
strip
n' :: (Maybe a, PlacerInfo)
n' = if Bool
strip then (Maybe a, PlacerInfo)
n else (Maybe a, PlacerInfo) -> (Maybe a, PlacerInfo)
forall a. (Maybe a, PlacerInfo) -> (Maybe a, PlacerInfo)
choosePlacer (Maybe a, PlacerInfo)
n
choosePlacer :: (Maybe a, PlacerInfo) -> (Maybe a, PlacerInfo)
choosePlacer (Maybe a, PlacerInfo)
i = case (Maybe a, PlacerInfo)
i of
(hi :: Maybe a
hi@(Just a
_),PlacerInfo
pi) -> (Maybe a
hi,case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
idS Placer
autoP Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
JustSpacer Spacer
s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
autoP Maybe Placer2
forall a. Maybe a
Nothing Spacer
idS
PlacerInfo
p -> PlacerInfo
p)
(Maybe a, PlacerInfo)
i -> (Maybe a, PlacerInfo)
i
attrMapLT :: (t -> [s] -> LeafInfo -> (t, s, LeafInfo))
-> (t -> [s] -> NodeInfo -> (t, s, NodeInfo))
-> t
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT t -> [s] -> LeafInfo -> (t, s, LeafInfo)
lf t -> [s] -> NodeInfo -> (t, s, NodeInfo)
nf = (t -> [s] -> LayoutInfo -> (t, s, LayoutInfo))
-> t -> PathTree LayoutInfo -> ([s], PathTree LayoutInfo)
forall i s a b.
(i -> [s] -> a -> (i, s, b))
-> i -> PathTree a -> ([s], PathTree b)
attrMapPathTree t -> [s] -> LayoutInfo -> (t, s, LayoutInfo)
f where
f :: t -> [s] -> LayoutInfo -> (t, s, LayoutInfo)
f t
i [s]
s LayoutInfo
a = case LayoutInfo
a of
LeafInfo LeafInfo
li -> (LeafInfo -> LayoutInfo) -> (t, s, LeafInfo) -> (t, s, LayoutInfo)
forall t c a b. (t -> c) -> (a, b, t) -> (a, b, c)
a3 LeafInfo -> LayoutInfo
LeafInfo ((t, s, LeafInfo) -> (t, s, LayoutInfo))
-> (t, s, LeafInfo) -> (t, s, LayoutInfo)
forall a b. (a -> b) -> a -> b
$ t -> [s] -> LeafInfo -> (t, s, LeafInfo)
lf t
i [s]
s LeafInfo
li
NodeInfo NodeInfo
ni -> (NodeInfo -> LayoutInfo) -> (t, s, NodeInfo) -> (t, s, LayoutInfo)
forall t c a b. (t -> c) -> (a, b, t) -> (a, b, c)
a3 NodeInfo -> LayoutInfo
NodeInfo ((t, s, NodeInfo) -> (t, s, LayoutInfo))
-> (t, s, NodeInfo) -> (t, s, LayoutInfo)
forall a b. (a -> b) -> a -> b
$ t -> [s] -> NodeInfo -> (t, s, NodeInfo)
nf t
i [s]
s NodeInfo
ni
a3 :: (t -> c) -> (a, b, t) -> (a, b, c)
a3 t -> c
c (a
i,b
s,t
b) = (a
i,b
s,t -> c
c t
b)
collectReqs :: PathTree LayoutInfo -> ([Spacer2], PathTree LayoutInfo)
collectReqs = ([[Spacer2] -> [Spacer2]] -> [Spacer2])
-> ([[Spacer2] -> [Spacer2]], PathTree LayoutInfo)
-> ([Spacer2], PathTree LayoutInfo)
forall t a b. (t -> a) -> (t, b) -> (a, b)
apFst (([[Spacer2] -> [Spacer2]] -> [Spacer2] -> [Spacer2])
-> [Spacer2] -> [[Spacer2] -> [Spacer2]] -> [Spacer2]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [[Spacer2] -> [Spacer2]] -> [Spacer2] -> [Spacer2]
forall b. [b -> b] -> b -> b
compose []) (([[Spacer2] -> [Spacer2]], PathTree LayoutInfo)
-> ([Spacer2], PathTree LayoutInfo))
-> (PathTree LayoutInfo
-> ([[Spacer2] -> [Spacer2]], PathTree LayoutInfo))
-> PathTree LayoutInfo
-> ([Spacer2], PathTree LayoutInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Spacer
-> [[Spacer2] -> [Spacer2]]
-> LeafInfo
-> (Spacer, [Spacer2] -> [Spacer2], LeafInfo))
-> (Spacer
-> [[Spacer2] -> [Spacer2]]
-> NodeInfo
-> (Spacer, [Spacer2] -> [Spacer2], NodeInfo))
-> Spacer
-> PathTree LayoutInfo
-> ([[Spacer2] -> [Spacer2]], PathTree LayoutInfo)
forall t s.
(t -> [s] -> LeafInfo -> (t, s, LeafInfo))
-> (t -> [s] -> NodeInfo -> (t, s, NodeInfo))
-> t
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT Spacer
-> [[Spacer2] -> [Spacer2]]
-> LeafInfo
-> (Spacer, [Spacer2] -> [Spacer2], LeafInfo)
forall p b.
Spacer
-> p
-> (LayoutRequest, b)
-> (Spacer, [Spacer2] -> [Spacer2], (LayoutRequest, b))
lf Spacer
-> [[Spacer2] -> [Spacer2]]
-> NodeInfo
-> (Spacer, [Spacer2] -> [Spacer2], NodeInfo)
forall a.
Spacer
-> [[Spacer2] -> [Spacer2]]
-> (Maybe a, PlacerInfo)
-> (Spacer, [Spacer2] -> [Spacer2], (Maybe a, PlacerInfo))
nf Spacer
idS where
lf :: Spacer
-> p
-> (LayoutRequest, b)
-> (Spacer, [Spacer2] -> [Spacer2], (LayoutRequest, b))
lf Spacer
s p
_ i :: (LayoutRequest, b)
i@(LayoutRequest
req,b
oplace) = (Spacer
s,[Spacer2] -> [Spacer2]
reqf,(LayoutRequest, b)
i) where
reqf :: [Spacer2] -> [Spacer2]
reqf = (Spacer -> Spacer1
unS Spacer
s LayoutRequest
lrSpacer2 -> [Spacer2] -> [Spacer2]
forall a. a -> [a] -> [a]
:)
lr :: LayoutRequest
lr = case b
oplace of
b
_ ->
LayoutRequest
req
nf :: Spacer
-> [[Spacer2] -> [Spacer2]]
-> (Maybe a, PlacerInfo)
-> (Spacer, [Spacer2] -> [Spacer2], (Maybe a, PlacerInfo))
nf Spacer
s [[Spacer2] -> [Spacer2]]
reqfs n :: (Maybe a, PlacerInfo)
n@(Maybe a
hi,PlacerInfo
pi) = case PlacerInfo
pi of
PlacerInfo
NoPlacerInfo -> (Spacer
s,[Spacer2] -> [Spacer2]
reqf,(Maybe a, PlacerInfo)
n)
JustSpacer Spacer
s1 ->
(Spacer
s Spacer -> Spacer -> Spacer
`compS` Spacer
s1,[Spacer2] -> [Spacer2]
reqf,(Maybe a, PlacerInfo)
n)
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
orp2 Spacer
s2 ->
(Spacer
inherS,[Spacer2] -> [Spacer2]
syntreq,(Maybe a, PlacerInfo)
n') where
rp2 :: Placer2
rp2@(LayoutRequest
req2,Rect -> [Rect]
p2) = Placer
compp Placer -> [Spacer2] -> Placer2
forall a.
Placer
-> [(LayoutRequest, Rect -> a)] -> (LayoutRequest, Rect -> [a])
`spacer2P` [Spacer2]
reqfl
reqfl :: [Spacer2]
reqfl = [Spacer2] -> [Spacer2]
reqf []
compp :: Placer
compp = if Bool
hashint then Placer
p else Spacer
sl Spacer -> Placer -> Placer
`spacerP` Placer
p
inherS :: Spacer
inherS = if Bool
hashint then Spacer
sl Spacer -> Spacer -> Spacer
`compS` Spacer
s2 else Spacer
s2
syntreq :: [Spacer2] -> [Spacer2]
syntreq = if [Spacer2] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spacer2]
reqfl then [Spacer2] -> [Spacer2]
forall a. a -> a
id else (Spacer -> Spacer1
unS Spacer
idS LayoutRequest
req2Spacer2 -> [Spacer2] -> [Spacer2]
forall a. a -> [a] -> [a]
:)
sl :: Spacer
sl = Spacer
s Spacer -> Spacer -> Spacer
`compS` Spacer
s1
hashint :: Bool
hashint = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
hi
orp2' :: Maybe Placer2
orp2' = if [Spacer2] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spacer2]
reqfl then Maybe Placer2
forall a. Maybe a
Nothing else Placer2 -> Maybe Placer2
forall a. a -> Maybe a
Just Placer2
rp2
n' :: (Maybe a, PlacerInfo)
n' = (Maybe a
hi,Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
orp2' Spacer
s2)
where reqf :: [Spacer2] -> [Spacer2]
reqf = [[Spacer2] -> [Spacer2]] -> [Spacer2] -> [Spacer2]
forall b. [b -> b] -> b -> b
compose [[Spacer2] -> [Spacer2]]
reqfs
compose :: [b -> b] -> b -> b
compose = ((b -> b) -> (b -> b) -> b -> b) -> (b -> b) -> [b -> b] -> b -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) b -> b
forall a. a -> a
id
doLayout :: Rect
-> PathTree LayoutInfo -> (PathTree LayoutInfo, [(Path, Rect)])
doLayout Rect
rect PathTree LayoutInfo
tree = ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect] -> (PathTree LayoutInfo, [(Path, Rect)])
forall p a a a b. (p -> [a] -> (a, (a, b))) -> p -> (a, b)
runIO (PathTree LayoutInfo
-> Path
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doLayoutIO PathTree LayoutInfo
tree []) [Rect
rect]
spacer2P :: Placer
-> [(LayoutRequest, Rect -> a)] -> (LayoutRequest, Rect -> [a])
spacer2P (P Placer1
p) [(LayoutRequest, Rect -> a)]
reqfs = (LayoutRequest
req,[Rect] -> [a]
s2f([Rect] -> [a]) -> (Rect -> [Rect]) -> Rect -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Rect -> [Rect]
p2) where
([LayoutRequest]
reqs,[Rect -> a]
s2s) = [(LayoutRequest, Rect -> a)] -> ([LayoutRequest], [Rect -> a])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LayoutRequest, Rect -> a)]
reqfs
s2f :: [Rect] -> [a]
s2f [Rect]
rs = [Rect -> a
s2 Rect
r | (Rect -> a
s2,Rect
r) <- [Rect -> a] -> [Rect] -> [(Rect -> a, Rect)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Rect -> a]
s2s [Rect]
rs]
(LayoutRequest
req,Rect -> [Rect]
p2) = Placer1
p [LayoutRequest]
reqs
doLayoutIO :: PathTree LayoutInfo
-> Path
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doLayoutIO PathTree LayoutInfo
t Path
path =
case PathTree LayoutInfo
t of
PathTree LayoutInfo
Tip -> PathTree LayoutInfo
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO PathTree LayoutInfo
t
Node (LeafInfo (LayoutRequest
l,Maybe Rect
maybeOldRect)) PathTree LayoutInfo
_ PathTree LayoutInfo
_ ->
[Rect] -> [(Path, Rect)] -> (Rect, ([Rect], [(Path, Rect)]))
forall a b. [a] -> b -> (a, ([a], b))
getIO ([Rect] -> [(Path, Rect)] -> (Rect, ([Rect], [(Path, Rect)])))
-> (Rect
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t t t b p a a.
(p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`bindIO` \ Rect
r ->
(Path, Rect)
-> [Rect] -> [(Path, Rect)] -> ((), ([Rect], [(Path, Rect)]))
forall a a. a -> a -> [a] -> ((), (a, [a]))
putIO (Path -> Path
forall a. [a] -> [a]
reverse Path
path,Rect
r) ([Rect] -> [(Path, Rect)] -> ((), ([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t b t b p a a.
(p -> t -> (b, (t, b)))
-> (t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`thenIO`
PathTree LayoutInfo
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO (LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
forall n. n -> PathTree n -> PathTree n -> PathTree n
Node (LeafInfo -> LayoutInfo
LeafInfo (LayoutRequest
l,Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
r)) PathTree LayoutInfo
forall n. PathTree n
Tip PathTree LayoutInfo
forall n. PathTree n
Tip)
Dynamic DynTree (PathTree LayoutInfo)
dt -> (DynTree (PathTree LayoutInfo) -> PathTree LayoutInfo)
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo) -> PathTree LayoutInfo,
([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO DynTree (PathTree LayoutInfo) -> PathTree LayoutInfo
forall n. DynTree (PathTree n) -> PathTree n
Dynamic ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo) -> PathTree LayoutInfo,
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap` DynTree (PathTree LayoutInfo)
-> Path
-> Int
-> Int
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
dynDoLayoutIO DynTree (PathTree LayoutInfo)
dt Path
path Int
0 Int
1
Node ni :: LayoutInfo
ni@(NodeInfo (Maybe String
_,PlacerInfo
pi)) PathTree LayoutInfo
lt PathTree LayoutInfo
rt ->
case PlacerInfo
pi of
SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
orp2 Spacer
s2 ->
case Maybe Placer2
orp2 of
Just (LayoutRequest
req,Rect -> [Rect]
placer2) ->
[Rect] -> [(Path, Rect)] -> (Rect, ([Rect], [(Path, Rect)]))
forall a b. [a] -> b -> (a, ([a], b))
getIO ([Rect] -> [(Path, Rect)] -> (Rect, ([Rect], [(Path, Rect)])))
-> (Rect
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t t t b p a a.
(p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`bindIO` \ Rect
r ->
[Rect]
-> [Rect] -> [(Path, Rect)] -> ((), ([Rect], [(Path, Rect)]))
forall a b. [a] -> [a] -> b -> ((), ([a], b))
ungetIO (Rect -> [Rect]
placer2 Rect
r) ([Rect] -> [(Path, Rect)] -> ((), ([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t b t b p a a.
(p -> t -> (b, (t, b)))
-> (t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`thenIO`
[Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doBranches
Maybe Placer2
Nothing -> PathTree LayoutInfo
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO PathTree LayoutInfo
t
PlacerInfo
_ -> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doBranches
where
doBranches :: [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doBranches =
(PathTree LayoutInfo -> PathTree LayoutInfo -> PathTree LayoutInfo)
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo
-> PathTree LayoutInfo -> PathTree LayoutInfo,
([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO (LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
-> PathTree LayoutInfo
forall n. n -> PathTree n -> PathTree n -> PathTree n
Node LayoutInfo
ni) ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo
-> PathTree LayoutInfo -> PathTree LayoutInfo,
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo -> PathTree LayoutInfo,
([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap` PathTree LayoutInfo
-> Path
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doLayoutIO PathTree LayoutInfo
lt (Direction
LDirection -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path)
([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo -> PathTree LayoutInfo,
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap` PathTree LayoutInfo
-> Path
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doLayoutIO PathTree LayoutInfo
rt (Direction
RDirection -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path)
dynDoLayoutIO :: DynTree (PathTree LayoutInfo)
-> Path
-> Int
-> Int
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
dynDoLayoutIO DynTree (PathTree LayoutInfo)
dt Path
path Int
n Int
i =
case DynTree (PathTree LayoutInfo)
dt of
DynTree (PathTree LayoutInfo)
DynTip -> DynTree (PathTree LayoutInfo)
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO DynTree (PathTree LayoutInfo)
dt
DynNode PathTree LayoutInfo
t DynTree (PathTree LayoutInfo)
lt DynTree (PathTree LayoutInfo)
rt ->
(PathTree LayoutInfo
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo))
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)]))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO PathTree LayoutInfo
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo)
forall n. n -> DynTree n -> DynTree n -> DynTree n
DynNode ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo) -> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap`
PathTree LayoutInfo
-> Path
-> [Rect]
-> [(Path, Rect)]
-> (PathTree LayoutInfo, ([Rect], [(Path, Rect)]))
doLayoutIO PathTree LayoutInfo
t (Int -> Direction
Dno (Int -> Int
unpos Int
n)Direction -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path) ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo)
-> DynTree (PathTree LayoutInfo) -> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo) -> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap`
DynTree (PathTree LayoutInfo)
-> Path
-> Int
-> Int
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
dynDoLayoutIO DynTree (PathTree LayoutInfo)
lt Path
path Int
n (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
i) ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo) -> DynTree (PathTree LayoutInfo),
([Rect], [(Path, Rect)])))
-> ([Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)])))
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
forall p t t a p b t a.
(p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap`
DynTree (PathTree LayoutInfo)
-> Path
-> Int
-> Int
-> [Rect]
-> [(Path, Rect)]
-> (DynTree (PathTree LayoutInfo), ([Rect], [(Path, Rect)]))
dynDoLayoutIO DynTree (PathTree LayoutInfo)
rt Path
path (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i) (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
i)
type IO' a i o = i -> o -> (a,(i,o))
runIO :: (p -> [a] -> (a, (a, b))) -> p -> (a, b)
runIO p -> [a] -> (a, (a, b))
io p
i =
let (a
a,(a
_,b
o)) = p -> [a] -> (a, (a, b))
io p
i []
in (a
a,b
o)
returnIO :: a -> a -> b -> (a, (a, b))
returnIO a
a a
i b
o = (a
a,(a
i,b
o))
putIO :: a -> a -> [a] -> ((), (a, [a]))
putIO a
o1 a
is [a]
os = ((),(a
is,a
o1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
os))
getIO :: [a] -> b -> (a, ([a], b))
getIO (a
i:[a]
is) b
os = (a
i, ([a]
is,b
os))
ungetIO :: [a] -> [a] -> b -> ((), ([a], b))
ungetIO [a]
is' [a]
is b
os = ((),([a]
is'[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
is,b
os))
bindIO :: (p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
bindIO p -> t -> (t, (t, b))
io1 t -> t -> p -> (a, (a, t))
xio2 p
i0 p
o0 =
let (t
x,(t
i1,b
o2)) = p -> t -> (t, (t, b))
io1 p
i0 t
o1
(a
y,(a
i2,t
o1)) = t -> t -> p -> (a, (a, t))
xio2 t
x t
i1 p
o0
in (a
y,(a
i2,b
o2))
thenIO :: (p -> t -> (b, (t, b)))
-> (t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
thenIO p -> t -> (b, (t, b))
f1 t -> p -> (a, (a, t))
f2 = p -> t -> (b, (t, b))
f1 (p -> t -> (b, (t, b)))
-> (b -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
forall p t t t b p a a.
(p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`bindIO` (t -> p -> (a, (a, t))) -> b -> t -> p -> (a, (a, t))
forall a b. a -> b -> a
const t -> p -> (a, (a, t))
f2
p -> t -> (t -> a, (p, b))
fIO ap :: (p -> t -> (t -> a, (p, b)))
-> (p -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap` p -> t -> (t, (a, t))
xIO = p -> t -> (t -> a, (p, b))
fIO (p -> t -> (t -> a, (p, b)))
-> ((t -> a) -> p -> t -> (a, (a, t))) -> p -> t -> (a, (a, b))
forall p t t t b p a a.
(p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`bindIO` \ t -> a
f ->
p -> t -> (t, (a, t))
xIO (p -> t -> (t, (a, t)))
-> (t -> a -> t -> (a, (a, t))) -> p -> t -> (a, (a, t))
forall p t t t b p a a.
(p -> t -> (t, (t, b)))
-> (t -> t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`bindIO` \ t
x ->
a -> a -> t -> (a, (a, t))
forall a a b. a -> a -> b -> (a, (a, b))
returnIO (t -> a
f t
x)