{-# 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 :: forall hi ho. String -> K hi ho -> K hi ho
debugK =
    if Bool
dbg
    then \ String
msg -> forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
String -> f hi ho -> f hi ho
echoStderrK (String
"AutoLayout: "forall a. [a] -> [a] -> [a]
++String
msg)
    else forall a b. a -> b -> a
const 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 = 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 = forall n. n -> PathTree n -> PathTree n -> PathTree n
Node (NodeInfo -> LayoutInfo
NodeInfo (forall a. a -> Maybe a
Just String
"top",PlacerInfo
NoPlacerInfo)) forall n. PathTree n
Tip forall n. PathTree n
Tip

data LayoutInfo
  = NodeInfo NodeInfo
  | LeafInfo LeafInfo -- only in leaves
  deriving (Int -> LayoutInfo -> ShowS
[LayoutInfo] -> ShowS
LayoutInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LayoutInfo] -> ShowS
$cshowList :: [LayoutInfo] -> ShowS
show :: LayoutInfo -> String
$cshow :: LayoutInfo -> String
showsPrec :: Int -> LayoutInfo -> ShowS
$cshowsPrec :: Int -> LayoutInfo -> ShowS
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 -> ShowS
[PlacerInfo] -> ShowS
PlacerInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlacerInfo] -> ShowS
$cshowList :: [PlacerInfo] -> ShowS
show :: PlacerInfo -> String
$cshow :: PlacerInfo -> String
showsPrec :: Int -> PlacerInfo -> ShowS
$cshowsPrec :: Int -> PlacerInfo -> ShowS
Show)

data PlacementState
  = Placed (Rect->Rect)
  | Waiting 
  deriving (Int -> PlacementState -> ShowS
[PlacementState] -> ShowS
PlacementState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlacementState] -> ShowS
$cshowList :: [PlacementState] -> ShowS
show :: PlacementState -> String
$cshow :: PlacementState -> String
showsPrec :: Int -> PlacementState -> ShowS
$cshowsPrec :: Int -> PlacementState -> ShowS
Show)

autoLayoutF :: F a b -> F a b
autoLayoutF = 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' :: forall a b. Bool -> Sizing -> F a b -> F a b
autoLayoutF' Bool
nowait Sizing
sizing F a b
fud =
    forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF 
      (forall a b.
F a b -> F (Either (Path, Rect) a) (Either (Path, LayoutMessage) b)
userLayoutF (forall {hi} {ho}. F hi ho -> F hi ho
layoutDoNow F a b
fud)) 
      ({- spyF -} (forall {i} {o}. Sizing -> F i o -> F i o
sizingF Sizing
sizing (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 forall a. a -> a
id else PlacementState
Waiting

autoLayoutMgrK0 :: PlacementState
-> PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
autoLayoutMgrK0 PlacementState
pstate PathTree LayoutInfo
ltree =
  forall hi ho. String -> K hi ho -> K hi ho
debugK String
"autoLayoutMgrK" 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)) $
    forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK 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 ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK String
"LayoutDoNow" forall a b. (a -> b) -> a -> b
$
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show PathTree LayoutInfo
ltree) forall a b. (a -> b) -> a -> b
$
	    PathTree LayoutInfo -> K (Path, LayoutMessage) (Path, Rect)
newPlace PathTree LayoutInfo
ltree
	  LayoutRequest LayoutRequest
req ->
	       forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" Layout "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (LayoutRequest -> Size
minsize LayoutRequest
req)) forall a b. (a -> b) -> a -> b
$
	       forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show PathTree LayoutInfo
ltree') 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 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 ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" LayoutHint "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
hint) forall a b. (a -> b) -> a -> b
$
	    (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (forall {a} {a}. a -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertHint String
hint)
	  LayoutPlacer Placer
placer ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" LayoutPlacer ...") forall a b. (a -> b) -> a -> b
$
	    (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (forall {a} {a}. Placer -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertPlacer Placer
placer)
	  LayoutSpacer Spacer
spacer ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" LayoutSpacer ...") forall a b. (a -> b) -> a -> b
$
	    (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
updnode (forall {a}. Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
insertSpacer Spacer
spacer)
	  -- LayoutReplaceSpacer is sent by dynSpacerF.
	  LayoutReplaceSpacer Spacer
spacer ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" LayoutReplaceSpacer ...") forall a b. (a -> b) -> a -> b
$
	    (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
replnode (forall {a}. Spacer -> (a, PlacerInfo) -> (a, PlacerInfo)
replaceSpacer Spacer
spacer)
	  LayoutReplacePlacer Placer
placer ->
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show Path
path forall a. [a] -> [a] -> [a]
++ String
" LayoutReplacePlacer ...") forall a b. (a -> b) -> a -> b
$
	    (NodeInfo -> NodeInfo) -> K (Path, LayoutMessage) (Path, Rect)
replnode (forall {a}. Placer -> (a, PlacerInfo) -> (a, PlacerInfo)
replacePlacer Placer
placer)
	  LayoutMessage
LayoutDestroy -> 
	    forall hi ho. String -> K hi ho -> K hi ho
debugK (forall a. Show a => a -> String
show (Path
path,PathTree LayoutInfo
ltree) forall a. [a] -> [a] -> [a]
++ String
" LayoutDestroy") forall a b. (a -> b) -> a -> b
$
	    -- should check if the subtree contains anything but hints.
	    if forall {n}. Show n => PathTree n -> Path -> Bool
newBox PathTree LayoutInfo
ltree Path
path then 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)
_ -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd LayoutMessage
layoutmsg)) forall a b. (a -> b) -> a -> b
$ K (Path, LayoutMessage) (Path, Rect)
same
	  LayoutScrollStep  Int
_ -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd LayoutMessage
layoutmsg)) 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)) ->
          forall hi ho. String -> K hi ho -> K hi ho
debugK (String
"splitting 1 Place into "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Path, Rect)]
msgs)) forall a b. (a -> b) -> a -> b
$
          forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Message a b
High [(Path, Rect)]
msgs) 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 Rect -> Rect
s2 -> Rect -> Rect
s2
			PlacementState
_ -> forall a. a -> a
id
      Low FResponse
_ -> 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 Rect -> Rect
_ -> 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
_) -> 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) ->
	     forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd LayoutRequest
req)) 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 = forall {t}.
(t -> t) -> t -> PathTree t -> Path -> (t -> t) -> PathTree t
updateNode forall a. a -> a
id LayoutInfo
emptyNode PathTree LayoutInfo
t Path
path 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
_ -> forall a. Maybe a
Nothing
	   PlacerInfo
_ -> forall a. a -> Maybe a
Just a
hint,PlacerInfo
pi)

insertPlacer :: Placer -> (a, PlacerInfo) -> (Maybe a, PlacerInfo)
insertPlacer Placer
placer (a
hint,PlacerInfo
pi) = (forall a. Maybe a
Nothing,case PlacerInfo
pi of
   PlacerInfo
NoPlacerInfo -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
idS Placer
placer forall a. Maybe a
Nothing Spacer
idS
   JustSpacer Spacer
s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
placer 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)
			           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 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]
p2rforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. [a] -> a
headforall 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 Spacer
s -> Spacer -> PlacerInfo
JustSpacer Spacer
spacer
	    SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
p2 Spacer
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 forall a. Maybe a
Nothing Spacer
idS
	    JustSpacer Spacer
s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
placer forall a. Maybe a
Nothing Spacer
idS
	    SpacerPlacer Spacer
s1 Placer
p Maybe Placer2
p2 Spacer
s2 -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s1 Placer
placer forall a. Maybe a
Nothing Spacer
s2

updateLeaf :: Path -> LayoutRequest -> PathTree LayoutInfo -> PathTree LayoutInfo
updateLeaf Path
path LayoutRequest
l PathTree LayoutInfo
t =
  forall {t}.
(t -> t) -> t -> PathTree t -> Path -> (t -> t) -> PathTree t
updateNode LayoutInfo -> LayoutInfo
invalid LayoutInfo
emptyNode PathTree LayoutInfo
t Path
path (forall a b. a -> b -> a
const (LeafInfo -> LayoutInfo
LeafInfo (LayoutRequest
l,forall a. Maybe a
Nothing)))

pruneLTree :: Path -> PathTree LayoutInfo -> PathTree LayoutInfo
pruneLTree Path
path PathTree LayoutInfo
t = forall {t}. (t -> t) -> t -> PathTree t -> Path -> PathTree t
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 (forall {t} {b} {a}. (t -> b) -> (a, t) -> (a, b)
apSnd (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)) forall a. a -> a
id
 
newBox :: PathTree n -> Path -> Bool
newBox PathTree n
x = forall {n} {t}.
Show n =>
(PathTree n -> t) -> t -> PathTree n -> Path -> t
subTree (forall a b. a -> b -> a
const Bool
False) Bool
True PathTree n
x

invalid :: LayoutInfo -> LayoutInfo
invalid (NodeInfo NodeInfo
i) = NodeInfo -> LayoutInfo
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 forall a. Maybe a
Nothing Spacer
s2)
    invalid' (a, PlacerInfo)
ni = (a, PlacerInfo)
ni

emptyNode :: LayoutInfo
emptyNode = NodeInfo -> LayoutInfo
NodeInfo (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 = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {i} {s}.
(i -> [s] -> LeafInfo -> (i, s, LeafInfo))
-> (i -> [s] -> NodeInfo -> (i, s, NodeInfo))
-> i
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT forall {a} {p} {c}. a -> p -> c -> (a, (), c)
lf 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
	    (Maybe a
Nothing,SpacerPlacer Spacer
_ Placer
_ Maybe Placer2
_ Spacer
_) -> Bool
True
	    (Maybe a, PlacerInfo)
_ -> Bool
strip --
     n' :: (Maybe a, PlacerInfo)
n' = if Bool
strip then (Maybe a, PlacerInfo)
n else 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 forall a. Maybe a
Nothing Spacer
idS
     JustSpacer Spacer
s -> Spacer -> Placer -> Maybe Placer2 -> Spacer -> PlacerInfo
SpacerPlacer Spacer
s Placer
autoP forall a. Maybe a
Nothing Spacer
idS
     PlacerInfo
p -> PlacerInfo
p)
   (Maybe a, PlacerInfo)
i -> (Maybe a, PlacerInfo)
i

attrMapLT :: (i -> [s] -> LeafInfo -> (i, s, LeafInfo))
-> (i -> [s] -> NodeInfo -> (i, s, NodeInfo))
-> i
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT i -> [s] -> LeafInfo -> (i, s, LeafInfo)
lf i -> [s] -> NodeInfo -> (i, s, NodeInfo)
nf = forall i s a b.
(i -> [s] -> a -> (i, s, b))
-> i -> PathTree a -> ([s], PathTree b)
attrMapPathTree i -> [s] -> LayoutInfo -> (i, s, LayoutInfo)
f where
   f :: i -> [s] -> LayoutInfo -> (i, s, LayoutInfo)
f i
i [s]
s LayoutInfo
a = case LayoutInfo
a of
     LeafInfo LeafInfo
li -> forall {t} {c} {a} {b}. (t -> c) -> (a, b, t) -> (a, b, c)
a3 LeafInfo -> LayoutInfo
LeafInfo forall a b. (a -> b) -> a -> b
$ i -> [s] -> LeafInfo -> (i, s, LeafInfo)
lf i
i [s]
s LeafInfo
li
     NodeInfo NodeInfo
ni -> forall {t} {c} {a} {b}. (t -> c) -> (a, b, t) -> (a, b, c)
a3 NodeInfo -> LayoutInfo
NodeInfo forall a b. (a -> b) -> a -> b
$ i -> [s] -> NodeInfo -> (i, s, NodeInfo)
nf i
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 = forall {t} {a} {b}. (t -> a) -> (t, b) -> (a, b)
apFst (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {b}. [b -> b] -> b -> b
compose []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {i} {s}.
(i -> [s] -> LeafInfo -> (i, s, LeafInfo))
-> (i -> [s] -> NodeInfo -> (i, s, NodeInfo))
-> i
-> PathTree LayoutInfo
-> ([s], PathTree LayoutInfo)
attrMapLT forall {p} {b}.
Spacer
-> p
-> (LayoutRequest, b)
-> (Spacer, [Spacer2] -> [Spacer2], (LayoutRequest, b))
lf 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
lrforall 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 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spacer2]
reqfl then forall a. a -> a
id else (Spacer -> Spacer1
unS Spacer
idS LayoutRequest
req2forall a. a -> [a] -> [a]
:)
		   sl :: Spacer
sl = Spacer
s Spacer -> Spacer -> Spacer
`compS` Spacer
s1
		   hashint :: Bool
hashint = forall a. Maybe a -> Bool
isJust Maybe a
hi
		   orp2' :: Maybe Placer2
orp2' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spacer2]
reqfl then forall a. Maybe a
Nothing else 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 = forall {b}. [b -> b] -> b -> b
compose [[Spacer2] -> [Spacer2]]
reqfs

  compose :: [b -> b] -> b -> b
compose = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id

doLayout :: Rect
-> PathTree LayoutInfo -> (PathTree LayoutInfo, [(Path, Rect)])
doLayout Rect
rect PathTree LayoutInfo
tree = 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]
s2fforall b c a. (b -> c) -> (a -> b) -> a -> c
.Rect -> [Rect]
p2) where
   ([LayoutRequest]
reqs,[Rect -> a]
s2s) = 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) <- 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 -> 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
_ ->
      forall {a} {b}. [a] -> b -> (a, ([a], b))
getIO 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 ->
      forall {a} {a}. a -> a -> [a] -> ((), (a, [a]))
putIO (forall a. [a] -> [a]
reverse Path
path,Rect
r) forall {p} {t} {t} {t} {b} {p} {a} {a}.
(p -> t -> (t, (t, b)))
-> (t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
`thenIO` 
         -- check if r is different from old rect?
      forall {a} {a} {b}. a -> a -> b -> (a, (a, b))
returnIO (forall n. n -> PathTree n -> PathTree n -> PathTree n
Node (LeafInfo -> LayoutInfo
LeafInfo (LayoutRequest
l,forall a. a -> Maybe a
Just Rect
r)) forall n. PathTree n
Tip forall n. PathTree n
Tip)
    Dynamic DynTree (PathTree LayoutInfo)
dt -> forall {a} {a} {b}. a -> a -> b -> (a, (a, b))
returnIO forall n. DynTree (PathTree n) -> PathTree n
Dynamic forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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) ->
		   forall {a} {b}. [a] -> b -> (a, ([a], b))
getIO 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 ->
		   forall {a} {b}. [a] -> [a] -> b -> ((), ([a], b))
ungetIO (Rect -> [Rect]
placer2 Rect
r) forall {p} {t} {t} {t} {b} {p} {a} {a}.
(p -> t -> (t, (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 -> 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 =
	  forall {a} {a} {b}. a -> a -> b -> (a, (a, b))
returnIO (forall n. n -> PathTree n -> PathTree n -> PathTree n
Node LayoutInfo
ni) forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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
Lforall a. a -> [a] -> [a]
:Path
path)
	                      forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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
Rforall 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 -> 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 ->
      forall {a} {a} {b}. a -> a -> b -> (a, (a, b))
returnIO forall n. n -> DynTree n -> DynTree n -> DynTree n
DynNode forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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)forall a. a -> [a] -> [a]
:Path
path) forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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
2forall a. Num a => a -> a -> a
*Int
i) forall {p} {t} {t} {a} {t} {b} {t} {a}.
(p -> t -> (t -> a, (t, b)))
-> (t -> 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
nforall a. Num a => a -> a -> a
+Int
i) (Int
2forall 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
o1forall 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'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 -> (t, (t, b)))
-> (t -> p -> (a, (a, t))) -> p -> p -> (a, (a, b))
thenIO p -> t -> (t, (t, b))
f1 t -> p -> (a, (a, t))
f2 = p -> t -> (t, (t, b))
f1 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` forall a b. a -> b -> a
const t -> p -> (a, (a, t))
f2

p -> t -> (t -> a, (t, b))
fIO ap :: (p -> t -> (t -> a, (t, b)))
-> (t -> t -> (t, (a, t))) -> p -> t -> (a, (a, b))
`ap` t -> t -> (t, (a, t))
xIO = p -> t -> (t -> a, (t, b))
fIO 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 ->
               t -> t -> (t, (a, t))
xIO 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 ->
	       forall {a} {a} {b}. a -> a -> b -> (a, (a, b))
returnIO (t -> a
f t
x)