Generic display functions for abstract widgets

\begin{code}
module DisplaySimple where
import WH
import Widget
import PileArray
import IOExts
import FranCore
import Identify
import Monad
import FM
import MapG
import Conf
import GUIDef
\end{code}

We use the DisplayInfo type to pass actions down to all child widgets.
Widgets may be visible at any given time; will be deleted on a given event;
appear in some form of pile (see PileArray.lhs); may have listeners to their
user input; we also have a unique name supply for use.

\begin{code}
data DisplayInfo = DisplayInfo {visible :: ! BoolB,
			        dieE :: ! (Event Bool),
				pArray :: ! PileArray,
				bindEvents :: [Bind],
				nameRef :: IORef Int,
				style :: Conf Style,
				guiDef_ :: GUIDef}

data Bind = Bind (forall w . Bindable w => w -> IO (IO ()))

newName :: IORef Int -> IO Int
newName ref = do x<- readIORef ref;writeIORef ref (x+1);return x

initDisplayInfo :: GUIDef -> Event () -> IO DisplayInfo
initDisplayInfo = initDisplayInfo' emptyConf

initDisplayInfo' :: Conf Style -> GUIDef -> Event () -> IO DisplayInfo
initDisplayInfo' s guiDef die  = do
 parr <- pileArray 30
 ref <- newIORef 0
 return $! DisplayInfo trueB (die -=> True) parr [] ref s guiDef
\end{code}

Display an individual item, given the item; a function to convert boolean
visibility into display actions; a hide action to perform when the widget 
is deleted (if it is currently visible; and a delete action to perform 
when the widget dies. Along with the Display info for the widget.

\begin{code}
displayItem :: (Bindable w,WidgetItem w) => w -> (BoolB -> IOB ()) 
	    -> IO () -> IO () 
	    -> DisplayInfo
            -> IO ()
displayItem w dispB hide del (DisplayInfo {visible = vis,dieE = dieE,
				           bindEvents = es,
 					   guiDef_ = guiDef}) = do 
  rm <- addIOB (dispB vis)
  rms <- mapM (\(Bind e) -> e w) es
  rml <- addListener (onceE' dieE)
		    (snapshotL_ vis $ mkL $ \b -> do 
				rm;sequence_ rms;del;when b $ hide)
  addFinaliserW w (do rm;sequence_ rms;rml)
  return ()
\end{code}

display a widget in a pile array. We need to generate a unique pile array
name for it; insert it into the pile (associating any groups there may
be with it; widgets are initially hidden. When we show and hide the widget
we must update the pile array.

\begin{code}
displayPAItem :: (Bindable w,WidgetItem w) => 
	       PileArray -- the pile the widget is in
	    -> w  -- the widget
	    -> ((Bool -> b -> IO ()) -> BoolB -> IOB ()) 
                    -- how to handle showing and hiding the widget 
	    -> (EltName -> b -> IO ())
                    -- show the widget (with some abstract type specific data)
	    -> (IO ())
                    -- hide the widget
	    -> DisplayInfo -- the display info
	    -> [GroupRef] -- the groups the widget is in
            -> IO EltName

displayPAItem pa w mkb showIt hideIt di gps = do
  elt <- getEltName pa
  insertPileElt pa (uniqueId w) elt Nothing gps
  hidePileElt pa elt
  let disp True ps = do
	showPileElt pa elt
	showIt elt ps 
      disp False _ = do
	hidePileElt pa elt
	hideIt
  displayItem w (mkb disp) hideIt (deletePileElt pa elt) 
		di
  return elt
\end{code}

find the element below the widget in the given pile

\begin{code}
findEltAbove :: PileArray -> EltName -> IO (Maybe EltData)
findEltAbove pa elt = do
	mbd <- getEltData pa elt
	mbe <- maybe (return Nothing)
		       (maybe (return Nothing)
			      (getEltData pa)
			 . visBelowElt) mbd
        return mbe
\end{code}

display an abstract widget, given a function to display an item;
a function to make a group for moving items in the stacking order;
the DisplayInfo and some type specific display info.

\begin{code}
displayW :: (DisplayInfo -> b -> a -> IO ())
	 -> (DisplayInfo -> b -> IO (MkMoveOp b)) 
         -> DisplayInfo -> b 
         -> GWidgetB a 
         -> IO ()
displayW disp gp info sinfo EmptyW = return ()

-- compose the two widgets displaying the widget at the back first
displayW disp gp info sinfo (Compose w1 w2) = do
 displayW disp gp info sinfo w2
 displayW disp gp info sinfo w1

displayW disp gp info sinfo (GWidgetB w) = disp info sinfo w

-- when we have an ifB, display the first widget when true, and the second
-- when False
displayW disp gp info@(DisplayInfo {visible = vis}) sinfo (CondWUnopt b w1 w2)
 =
 do displayW disp gp (info {visible = vis &&* b}) sinfo w1
    displayW disp gp (info {visible = vis &&* notB b}) sinfo w2


-- handle style
displayW disp gp info@(DisplayInfo {style =oldcs,visible=vis}) sinfo (WithStyle cs w) =
 displayW disp gp (info {style = composeConfs $ cs ++ [oldcs]}) sinfo w


-- bind user input by adding a listener to those for all widgets
displayW disp gp info@(DisplayInfo {bindEvents = es}) sinfo (GrabInput a l w)
 =
 displayW disp gp (info{bindEvents = (Bind (\w -> bind w a l)):es}) sinfo w

-- display a pile of widgets
displayW (disp :: (DisplayInfo -> b -> a -> IO ())) gp info sinfo 
         (PileW (APile init alter)) = do
 mkmoveop <- gp info sinfo -- make a group for moving stacking order
 is <- init -- get initial pile
 rm <- displayPile is alter mkmoveop -- display the pile
 addListener (onceE' $ dieE info) (mkL_ rm) -- stop when deleted
 return ()
   where
   displayPile :: [(Ident,GWidgetB a)] -> Event (PileOp (GWidgetB a))
	       -> (DisplayInfo,b,MkMoveOp' b) -> IO Remover
   displayPile is alter (di,pi,mkmoveop) = do
      displayList is 
      rm <- addListener alter (mkL dispE)
      addListener (onceE' $ dieE di) $ mkL_ rm
    where
     -- display a list of items
     displayList :: [(Ident,GWidgetB a)] -> IO ()
     displayList as =
             mapM_ (\(n,a) -> displayOne n a PlaceTop)
		   (reverse as)

     dispE :: PileOp (GWidgetB a) -> IO ()
     dispE (InsertElt a id pos) = 
       displayOne id a pos
     dispE (ResetElts rs) =
       displayList rs
     dispE _ = return ()

     isDelete :: Ident -> PileOp (GWidgetB a) -> Maybe Bool
     isDelete n (DeleteElt n1) | n == n1 = Just True
     isDelete n (ResetElts _) = Just True
     isDelete n _ = Nothing

     -- display an item. It should be deleted on a delete event,
     -- (ie on reset or delete that element)

     displayOne :: Ident -> GWidgetB a -> PlacePos Ident -> IO ()
     displayOne id a pos = do
      let dieE' = dieE info .|. mapMaybeE  (isDelete id) alter

      -- turn the widget into a pile for group restacking
      (moveop,info,sinfo) <- mkmoveop (di {dieE = dieE'}) pi id pos 

      displayW disp gp info sinfo a
      rm <- raiseIt id moveop 
      addListener (onceE' dieE') $ mkL_ rm
      return ()

     -- when we hear move ops restack the widget.
     raiseIt :: Ident -> MoveOp -> IO Remover
     raiseIt id moveop = do
      addListener  alter  (mapMaybeL (raiser id) moveop)
      
     raiser :: Ident -> PileOp (GWidgetB a) -> Maybe (PlacePos Ident)
     raiser id (MoveElt id' pos) | id == id' = Just pos
     raiser _ _ = Nothing
\end{code}

Make a group to allow restacking. We first make a generic group, with an 
operation to make individual stacking groups (we do this for a whole pile).

We then make specific groups with a name and an initial position. This 
returns a listener that hears about restacking of that group.

\begin{code}
type MkMoveOp b = (DisplayInfo,b,MkMoveOp' b)

type MkMoveOp' b = DisplayInfo -> b -> Ident -> PlacePos Ident
		 -> IO (MoveOp,DisplayInfo,b)
type MoveOp = Listener (PlacePos Ident)
\end{code}

To make a mover group.
\begin{code}
mkMover :: PileArray -- the pile
        -> IORef (FiniteMap Ident c) 
             -- a map to lookup object names and get back a value to refer to
	     -- when restacking 
        -> Ident -- the identifier of this object
        -> c -- the restacking identifier of this object
	-> (PileArray -> c -> Maybe c -> IO d) 
             -- raise an element above another
	-> (PileArray -> c -> Maybe c -> IO d)
             -- lower an element below another
	-> Event Bool -- when to stop
	-> IO (PlacePos Ident -> IO ())
mkMover pa fmv ident elt raisePileElt lowerPileElt dieE = do
 let findEltinTbl v n = do fm <- readIORef v;return $ lookupFM fm n
 updIORef fmv $ \fm -> addToFM fm ident elt
 addListener (onceE' dieE) $ mkL_ $updIORef fmv (\fm -> delFromFM fm ident)
 let moveInPile pos = do
           posg <- mapG (findEltinTbl fmv) pos
           case posg of
            PlaceBefore g -> raisePileElt pa elt g
            PlaceAfter g -> lowerPileElt pa elt g
            PlaceTop -> raisePileElt pa elt Nothing
            PlaceBottom -> lowerPileElt pa elt Nothing
	   return ()
 return (moveInPile)
\end{code}