{-# LANGUAGE CPP #-}
module AutoLayout(autoLayoutF,autoLayoutF',nowait) where
--import Prelude hiding (IO)
import LayoutRequest(LayoutMessage(..),LayoutResponse(..),LayoutRequest(minsize),LayoutHint,Spacer,Placer(..),Placer2,unS)
import LayoutDoNow
import PathTree hiding (pos)
import Geometry(Rect)
import Fudget
--import Spops
--import FudgetIO
import NullF(getK,putK,putsK) --,F,K
import Loops(loopThroughRightF)
import UserLayoutF
--import Xtypes
--import Event
--import Command
import FRequest
--import Path
import Direction
--import Placers
--import LayoutDir(LayoutDir)
--import CompOps
import IoF(ioF)
import CmdLineEnv(argFlag)
--import EitherUtils()
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 ContinuationIO(stderr)

-- debugging:
import StdIoUtil(echoStderrK)
--import NonStdTrace(trace)
--import Maptrace(ctrace)
--import SpyF

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 -- only in leaves
  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)
  -- (Layout s fh fv,Nothing) : received layout req, layout not computed
  -- (Layout s fh fv,Just rect) : rect is current placement.

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)) 
      ({- spyF -} (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))))
	-- Note that the sizingF filter is not wrapped around fud and hence
	-- does not have to examine all commands and events!
  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 =
    --echoK (show (pstate,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 & LayoutPlacer are only sent during initialisation.
	  -- They will be received before any child Layout requests.
	  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 is sent by dynSpacerF.
	  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
$
	    -- should check if the subtree contains anything but hints.
	    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))
	      -- !! forgetPlaces should be called when the structure changes,
	      -- but not when an existing fudget requests a new size...
	  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 -- !!! handle other layout requests?!
        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 -- hmm

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

-- strip hints below placer, insert autoP where there are hints left
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
{- -- You can use static sizing of shell windows instead of this:
	      Just (Rect _ currentsize) ->
		-- use current size, not originally requested size
		--ctrace "spacer" ("current",i) $
		mapLayoutSize (const currentsize) req
-}
	      b
_ -> --ctrace "spacer" ("nocurrent",i)
	           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 ->
	 --ctrace "spacer" (fst ((s `compS` s1) (Layout origin False False))) $
	 (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 ->
	  --ctrace "spacer" (n,fst (compp $ [Layout origin False False])) $ 
	             (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)
--	  Just (req,_) -> ctrace "spacer" (n,req) (s2,(idS req:),n)
    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` 
         -- check if r is different from old rect?
      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 -- no requests in this tree
	  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))
--getIO (i:is) os  = (Just i, (is,os))
--getIO []     os  = (Nothing,(is,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)