HistoryButtonsF.hs

module HistoryButtonsF where
import AllFudgets hiding (StreamProcIO(..))
import ReactiveF
import Monad(when)

-- Mostly taken from WWWBrowser...

historyButtonsF = loopThroughRightF ctrlF buttonsF
  where
    ctrlF = getFirst $ reactiveF ctrl . state0
    state0 first = ([],first,[])

    getFirst cont = getF $ either (\ _ -> getFirst cont) $
			   either cont (\ _ -> getFirst cont)

    ctrl = either fromButtons fromOutside
    fromButtons = either fromBack fromForward

    output = put . Right
    changeback = put . Left . Left
    changeforward = put . Left . Right

    set' (bs,cur,fs) =
       do set (bs,cur,fs)
	  changeback bs
	  changeforward fs

    goForward 0 h = return h
    goForward n (_,_,[]) = rfail
    goForward n (bs,cur,f:fs) = goForward (n-1) (cur:bs,f,fs)

    goBack n h = fliph `fmap` goForward n (fliph h)
    fliph (bs,cur,fs) = (fs,cur,bs)

    fromBack n = setput =<< goBack n =<< get
    fromForward n = setput =<< goForward n =<< get
    setput h@(_,cur,_) = set' h >> output cur

    fromOutside (Left new) =
        do (bs,cur,fs) <- get
	   when (cur==new) rfail
	   set' (cur:bs,new,[])

    fromOutside (Right new) =
        do (bs,cur,fs) <- get
	   set' (bs,new,fs)

    buttonsF = mbuttonF kl lArrowD >+< mbuttonF kr rArrowD
      where
         kl = k "Left"; kr = k "Right";
         k sym = setKeys [([Mod1],sym)]::Customiser (ButtonF a)

    mbuttonF keys lblf =
        post >^=< popupMenuF [] (dbuttonF keys lblf) >=^^< concatMapSP pre
      where
        pre alts = [Left (zip [1..limit] alts),Right (null alts)]
	limit = 30 -- maximum number of menu entries
	post = either id (const 1)

    dbuttonF keys lblf =
       buttonF'' keys (lblf True) >=^< Left . setLabel . lblf >=^^< idempotSP

    lArrowD = arrowD pts r
      where
	r = rR 12 3 4 4

    rArrowD = arrowD pts' r
      where
	pts' = [pP 16 10 - p | p<-pts]
	r = rR 0 3 4 4

    arrowD pts r disabled =
	spacedD (hvMarginS m m) $
	if disabled then outlineD else stackD [fillD,outlineD]
      where
        fillD =
	  fgD "white" $ fd [FillPolygon Convex CoordModeOrigin pts,
			     FillArc r 0 (64*360)]
        outlineD =
	  fgD ["blue4","#0000cc","black"] $
	      fd [DrawLines CoordModeOrigin pts,DrawArc r 0 (64*360)]

	m = Point 1 2
	fd = g . FixD (Point 17 11)

    pts = [pP 0 5,pP 5 0,pP 5 3,pP 10 3,pP 10 7,pP 5 7,pP 5 10,pP 0 5]