{-# 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 =
    if dbg
    then \ msg -> echoStderrK ("AutoLayout: "++msg)
    else const id
  where
    dbg = argFlag "ad" False

type LayoutTree = PathTree LayoutInfo

mapLT lf nf = mapPathTree (mapLayoutInfo lf nf)

top0 = Node (NodeInfo (Just "top",NoPlacerInfo)) Tip Tip

data LayoutInfo
  = NodeInfo NodeInfo
  | LeafInfo LeafInfo -- only in leaves
  deriving (Show)

mapLayoutInfo lf nf n = case n of
     NodeInfo n -> NodeInfo (nf n)
     LeafInfo l -> LeafInfo (lf 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 (Show)

data PlacementState
  = Placed (Rect->Rect)
  | Waiting 
  deriving (Show)

autoLayoutF = autoLayoutF' nowait Sizing.Dynamic

nowait = argFlag "nowait" False

autoLayoutF' :: Bool -> Sizing.Sizing -> F a b -> F a b
autoLayoutF' nowait sizing fud =
    loopThroughRightF 
      (userLayoutF (layoutDoNow fud)) 
      ({- spyF -} (sizingF sizing (ioF (autoLayoutMgrK0 state0 top0))))
	-- Note that the sizingF filter is not wrapped around fud and hence
	-- does not have to examine all commands and events!
  where
    state0 = if nowait then Placed id else Waiting

autoLayoutMgrK0 pstate ltree =
  debugK "autoLayoutMgrK" $
  autoLayoutMgrK pstate ltree

autoLayoutMgrK pstate ltree =
    --echoK (show (pstate,ltree)) $
    getK $ \ msg ->
    case msg of
      High (path,layoutmsg) ->
        case layoutmsg of
	  LayoutDoNow ->
	    debugK "LayoutDoNow" $
	    debugK (show ltree) $
	    newPlace ltree
	  LayoutRequest req ->
	       debugK (show path ++ " Layout "++show (minsize req)) $
	       debugK (show ltree') $
	       changePlacement ltree'
	    where ltree' = updateLeaf path req ltree''
	          ltree'' = if newBox ltree path
		            then forgetPlaces ltree
			    else ltree
	  -- LayoutHint & LayoutPlacer are only sent during initialisation.
	  -- They will be received before any child Layout requests.
	  LayoutHint hint ->
	    debugK (show path ++ " LayoutHint "++ show hint) $
	    updnode (insertHint hint)
	  LayoutPlacer placer ->
	    debugK (show path ++ " LayoutPlacer ...") $
	    updnode (insertPlacer placer)
	  LayoutSpacer spacer ->
	    debugK (show path ++ " LayoutSpacer ...") $
	    updnode (insertSpacer spacer)
	  -- LayoutReplaceSpacer is sent by dynSpacerF.
	  LayoutReplaceSpacer spacer ->
	    debugK (show path ++ " LayoutReplaceSpacer ...") $
	    replnode (replaceSpacer spacer)
	  LayoutReplacePlacer placer ->
	    debugK (show path ++ " LayoutReplacePlacer ...") $
	    replnode (replacePlacer placer)
	  LayoutDestroy -> 
	    debugK (show (path,ltree) ++ " LayoutDestroy") $
	    -- should check if the subtree contains anything but hints.
	    if newBox ltree path then debugK ("not in tree") same else
	    changePlacement (forgetPlaces (pruneLTree path ltree))
	      -- !! forgetPlaces should be called when the structure changes,
	      -- but not when an existing fudget requests a new size...
	  LayoutMakeVisible _ _ -> putK (Low (LCmd layoutmsg)) $ same
	  LayoutScrollStep  _ -> putK (Low (LCmd layoutmsg)) $ same
	  _ -> same -- !!! handle other layout requests?!
        where updnode  u = newTree (updateLNode path u ltree)
	      replnode u = changePlacement (forgetPlaces (updateLNode path u ltree))
      Low (LEvt (LayoutPlace rect)) ->
          debugK ("splitting 1 Place into "++show (length msgs)) $
          putsK (map High msgs) $
	  newTree ltree'
	where (ltree',msgs) = doLayout (s2 rect) ltree
	      s2 = case pstate of
			Placed s2 -> s2
			_ -> id
      Low _ -> debugK "Ignored low level msg" same
  where
    same = autoLayoutMgrK pstate ltree
    newTree t' = newState pstate t'
    newState p' t' = autoLayoutMgrK p' t'
    changePlacement ltree' =
      case pstate of
        Placed _ -> newPlace ltree'
	Waiting -> newTree ltree'
    newPlace ltree =
      let ltree' = chooseLayout ltree
      in case collectReqs ltree' of
           ([],_) -> debugK "newPlace without any requests in ltree" same
	   ((req,s2):_,ltree2) ->
	     putK (Low (layoutRequestCmd req)) $
	     newState (Placed s2) ltree2

updateLNode path i t = updateNode id emptyNode t path $
     \(NodeInfo ni) -> NodeInfo (i ni)

insertHint hint (_,pi) = (case pi of
	   SpacerPlacer _ _ _ _ -> Nothing
	   _ -> Just hint,pi)

insertPlacer placer (hint,pi) = (Nothing,case pi of
   NoPlacerInfo -> SpacerPlacer idS placer Nothing idS
   JustSpacer s -> SpacerPlacer s placer Nothing idS
   SpacerPlacer s1 p _ s2 -> SpacerPlacer (s1 `compS` s2) (p `compP` placer)
			           Nothing idS)
     where compP :: Placer -> Placer -> Placer
	   compP (P p1) (P p2) = P $ \ reqs ->
	       let (req1,p1r) = p1 [req2]
	           (req2,p2r) = p2 reqs
	       in (req1,p2r.head.p1r)

insertSpacer spacer (hint,pi) = (hint,case pi of
   NoPlacerInfo -> JustSpacer spacer
   JustSpacer s -> JustSpacer (s `compS` spacer)
   SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 p p2 (s2 `compS` spacer))

replaceSpacer spacer (hint,pi) = (hint,pi')
  where
    pi' = case pi of
            NoPlacerInfo -> JustSpacer spacer
	    JustSpacer s -> JustSpacer spacer
	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer spacer p p2 s2 -- hmm

replacePlacer placer (hint,pi) = (hint,pi')
  where
    pi' = case pi of
            NoPlacerInfo -> SpacerPlacer idS placer Nothing idS
	    JustSpacer s -> SpacerPlacer s placer Nothing idS
	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 placer Nothing s2

updateLeaf path l t =
  updateNode invalid emptyNode t path (const (LeafInfo (l,Nothing)))

pruneLTree path t = pruneTree invalid emptyNode t path

forgetPlaces = mapLT (apSnd (const Nothing)) id
 
newBox x = subTree (const False) True x

invalid (NodeInfo i) = NodeInfo (invalid' i)
  where
    invalid' (hi,SpacerPlacer s p p2 s2) = (hi,SpacerPlacer s p Nothing s2)
    invalid' ni = ni

emptyNode = NodeInfo (Nothing,NoPlacerInfo)

hasPlacer (Nothing,SpacerPlacer _ _ _ _) = True
hasPlacer _ = False

-- strip hints below placer, insert autoP where there are hints left
chooseLayout = snd . attrMapLT lf nf False where
  lf strip _ i = (strip,(),i)
  nf strip _ n = (strip',(),n') where
     strip' = case n of
	    (Nothing,SpacerPlacer _ _ _ _) -> True
	    _ -> strip --
     n' = if strip then n else choosePlacer n

choosePlacer i = case i of
   (hi@(Just _),pi) -> (hi,case pi of
     NoPlacerInfo -> SpacerPlacer idS autoP Nothing idS
     JustSpacer s -> SpacerPlacer s autoP Nothing idS
     p -> p)
   i -> i

attrMapLT lf nf = attrMapPathTree f where
   f i s a = case a of
     LeafInfo li -> a3 LeafInfo $ lf i s li
     NodeInfo ni -> a3 NodeInfo $ nf i s ni
   a3 c (i,s,b) = (i,s,c b)

collectReqs = apFst (flip compose []) . attrMapLT lf nf idS where
  lf s _ i@(req,oplace) = (s,reqf,i) where 
       reqf = (unS s lr:)
       lr = case 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
-}
	      _ -> --ctrace "spacer" ("nocurrent",i)
	           req
  nf s reqfs n@(hi,pi) = case pi of
       NoPlacerInfo -> (s,reqf,n)
       JustSpacer s1 ->
	 --ctrace "spacer" (fst ((s `compS` s1) (Layout origin False False))) $
	 (s `compS` s1,reqf,n)
       SpacerPlacer s1 p orp2 s2 ->
	  --ctrace "spacer" (n,fst (compp $ [Layout origin False False])) $ 
	             (inherS,syntreq,n') where
		   rp2@(req2,p2) = compp `spacer2P` reqfl
		   reqfl = reqf []
		   compp = if hashint then p else sl `spacerP` p
		   inherS = if hashint then sl `compS` s2 else s2
		   syntreq = if null reqfl then id else (unS idS req2:)
		   sl = s `compS` s1
		   hashint = isJust hi
		   orp2' = if null reqfl then Nothing else Just rp2
		   n' = (hi,SpacerPlacer s1 p orp2' s2)
--	  Just (req,_) -> ctrace "spacer" (n,req) (s2,(idS req:),n)
    where reqf = compose reqfs

  compose = foldr (.) id

doLayout rect tree = runIO (doLayoutIO tree []) [rect]

spacer2P (P p) reqfs = (req,s2f.p2) where
   (reqs,s2s) = unzip reqfs
   s2f rs = [s2 r | (s2,r) <- zip s2s rs]
   (req,p2) = p reqs

doLayoutIO t path =
  case t of
    Tip -> returnIO t
    Node (LeafInfo (l,maybeOldRect)) _ _ ->
      getIO `bindIO` \ r ->
      putIO (reverse path,r) `thenIO` 
         -- check if r is different from old rect?
      returnIO (Node (LeafInfo (l,Just r)) Tip Tip)
    Dynamic dt -> returnIO Dynamic `ap` dynDoLayoutIO dt path 0 1
    Node ni@(NodeInfo (_,pi)) lt rt ->
	case pi of
	  SpacerPlacer s1 p orp2  s2 ->
	    case orp2 of
	      Just (req,placer2) ->
		   getIO `bindIO` \ r ->
		   ungetIO (placer2 r) `thenIO`
		   doBranches
	      Nothing -> returnIO t -- no requests in this tree
	  _ -> doBranches
      where
        doBranches =
	  returnIO (Node ni) `ap` doLayoutIO lt (L:path)
	                      `ap` doLayoutIO rt (R:path)


dynDoLayoutIO dt path n i =
  case dt of
    DynTip -> returnIO dt
    DynNode t lt rt ->
      returnIO DynNode `ap`
      doLayoutIO t (Dno (unpos n):path) `ap`
      dynDoLayoutIO lt path n (2*i) `ap`
      dynDoLayoutIO rt path (n+i) (2*i)

--

type IO' a i o = i -> o -> (a,(i,o))

runIO io i =
  let (a,(_,o)) = io i []
  in (a,o)

returnIO a i o = (a,(i,o))
putIO o1 is os = ((),(is,o1:os))
getIO (i:is) os  = (i, (is,os))
--getIO (i:is) os  = (Just i, (is,os))
--getIO []     os  = (Nothing,(is,os))
ungetIO is' is os = ((),(is'++is,os))

bindIO io1 xio2 i0 o0  =
  let (x,(i1,o2)) = io1 i0 o1
      (y,(i2,o1)) = xio2 x i1 o0
  in (y,(i2,o2))

thenIO f1 f2 = f1 `bindIO` const f2

fIO `ap` xIO = fIO `bindIO` \ f ->
               xIO `bindIO` \ x ->
	       returnIO (f x)