Generic component widgets. Built on top of the system specific widget set,
and on top of abstract Components and Widgets.

\begin{code}
module ComponentWidgets where
import AbstractInterface

import WidgetSet

import qualified FranPrim as F
import StaticTypes
import qualified BehaviorTypes as B

import Maybe
import IOExts
import Utils
import List
import FM

import FRPWrap

import TreeIO
import Component
import Widget
import DisplayWidget
import ListB (fromList,toList,insertWith)
import TclPrimImpl (tcl_)
\end{code}

Tick every v seconds firing a primitive action, until the root window
is destroyed, or the remove IO action is run

\begin{code}
everyTick :: Double -> GUI (IO ())
everyTick v = do
 w <- getRootWindow
 withGUIDef $ \g -> do
  rm <- everyW v (runGUI g update) (guiInfo g)
  addFinaliserW w rm
  return rm
\end{code}

tick every v seconds until the root window is destroyed, telling an 
event about the tick events. Finish if we lose interest in the event.

\begin{code}
afterE :: Time -> GUI (Event ())
afterE v = do
 win <- getRootWindow
 withGUIDef $ \g -> do
  w <- newWire
  fixIO $ \rm -> do
   l <- fireListener' (input w) rm 
   rm <- afterW v (primAction g (l ())) (guiInfo g)
   addFinaliserW win rm
   return rm
  return (event w)

everyE :: Time -> GUI (Event ())
everyE v = do
 win <- getRootWindow
 withGUIDef $ \g -> do
  w <- newWire
  fixIO $ \rm -> do
   l <- fireListener' (input w) rm 
   rm <- everyW v (primAction g (l ())) (guiInfo g)
   addFinaliserW win rm
   return rm
  return (event w)
\end{code}

Rendering window components with components inside

\begin{code}
withRootWindow :: [Conf Window] -> Component -> WComponent
withRootWindow cs c = do
 w <- getRootWindow
 csetAllB windowNames w cs
 renderInWindow w c
 return $ wwidget w

mkWindow :: [Conf Window] -> Component -> WComponent
mkWindow cs c = do
 w <- window cs
 renderInWindow w c
 return $ wwidget w

--render a component in a window, by setting the current window context,
--displaying it and then resetting the window context

renderInWindow :: Window -> Component -> GUI ()
renderInWindow win c = do
 cur <- getCurrentWindow 
 setCurrentWindow ( win)
 w <- c
 withGUIDef $ displayWidget (WW win) w
 setCurrentWindow cur
\end{code}

Component definitions built on top of the WidgetSet widgets

The really simple ones

\begin{code}
mkMessage :: [Conf Message] -> Component
mkMessage = fmap widget . message

mkLabel :: [Conf Label] -> Component
mkLabel = fmap widget . label

mkButton :: [Conf Button] -> Listener () -> Component
mkButton cs l = fmap widget $ button (command l:cs) 

mkRadiobutton :: [Conf Radiobutton] -> Listener () -> Component
mkRadiobutton cs l = fmap widget $ radiobutton (command l:cs)

mkHScrollbar,mkVScrollbar :: [Conf Scrollbar] -> Component
mkHScrollbar cs = fmap widget $ hscroll cs
mkVScrollbar cs = fmap widget $ vscroll cs
\end{code}

components that sample their own value and tell that to their listener

\begin{code}
mkVScale,mkHScale :: [Conf Scale] -> Listener Int -> Component
mkVScale cs l = fmap widget $ vscale (commandSelf (liftIO . getScale) l:cs)
mkHScale cs l = fmap widget $ hscale (commandSelf (liftIO . getScale) l:cs)

mkCheckbutton :: [Conf Checkbutton] -> Listener Bool -> Component
mkCheckbutton cs l = 
  fmap widget $ checkbutton (commandSelf (liftIO . getCheck) l:cs)
\end{code}


-- Canvas -------------------------------------------
When we display a canvas we create a canvas, set it as the current context,
display the canvas component and then clear the canvas context

\begin{code}
mkCanvas :: [Conf Canvas] -> CComponent -> Component
mkCanvas cs cc = do
 can <- canvas cs
 setInCanvas can
 cw <- cc
 wr <- mkWire
 die <- liftIO $ fireListener (input wr)
 liftIO $ addFinaliserW can (die ())
 withGUIDef $ displayCanvasWidget (event wr) cw 
 clearFromCanvas 
 return $ widget can

mkCOval :: B.Vector2B -> [Conf COval] -> CComponent
mkCOval v c = fmap cwidget $ coval v c 

mkCLine :: [B.Point2B] -> [Conf CLine] -> CComponent
mkCLine p c = fmap cwidget $ cline p c

mkCArc :: B.Vector2B -> IntB -> IntB -> [Conf CArc] -> CComponent 
mkCArc v r1 r2 cs = fmap cwidget $ carc v r1 r2 cs

mkCRectangle :: B.Vector2B -> [Conf CRectangle] -> CComponent
mkCRectangle v cs = fmap cwidget $ crectangle v cs

mkCPolygon :: [B.Point2B] -> [Conf CPolygon] -> CComponent
mkCPolygon p cs = fmap cwidget $ cpolygon p cs

mkCText :: [Conf CText] -> CComponent
mkCText cs = fmap cwidget $ ctext cs

mkCBitmap :: [Conf CBitmap] -> CComponent
mkCBitmap cs = fmap cwidget $ cbitmap cs
\end{code}

To display a component in a canvas item, create a subpanel to 
display the component in and place this subpanel in the canvas item.
Connect all user input listeners from the cwindow to the every widget 
in the component through a wire. Bind requests are send along the wire.
Remove actions for the bind are placed in a ref cell. This can be used 
to unbind when no longer needed.

\begin{code}
mkCWindow :: [Conf CWindow] -> Component -> CComponent
mkCWindow cs c = fmap cwidget $ do 
 w <- getCurrentWindow
 p <- liftIO $ getWinPanel (widgetPrim w) >>= mkSubPanel
 wgt <- c
 wire <- mkWire
 tell <- liftIO $ fireListener (input wire)
 withGUIDef $ displayWidgetWith 
	    (Just $ Bind (\w -> 
		     F.addListener (event wire) (mkL $ \(a,l,ref) -> do
						 rm <- bind w a l
						 writeIORef ref rm)))
	    p wgt
 w <- cwindow (\ a l -> do ref <- newIORef (return ())
		           tell (a,l,ref)
		           return $ callRemoverRef ref) (raise p) (lower p)
	      (uniqueId p) cs
 liftIO $ addFinaliserW w (destroy p) 
 return w
\end{code}

Menus - now life starts to get a bit more complex, as in FranTk menu items
are an abstract data type.

make a menu button, and make a menu for its config option, either from a
static or dynamic list of items

\begin{code}
mkMenubutton :: [Conf Menubutton] -> Component 
mkMenubutton = fmap widget . menubutton 

withMenu :: [Conf Menu] -> [MenuItem] -> Conf Menubutton
withMenu cs mis = confGUI $ \w -> do 
		m <- menu' w cs
	        mapM_ (runMenuItem m PlaceBottom) mis
		csetB w [use_menu m] 

withMenuL :: [Conf Menu] -> ListB MenuItem -> Conf Menubutton
withMenuL cs mis = confGUI $ \w -> do
		m <- menu' w cs
		runMenuItems m mis
		csetB w [use_menu m]
\end{code}

make a menu as a GUI action with a static or dynamic list of items

\begin{code}
mkMenu :: [Conf Menu] -> [MenuItem] -> GUI Menu
mkMenu cs items = do
 m <- menu cs
 mapM_ (runMenuItem m PlaceBottom) items
 return m

mkMenuL :: [Conf Menu] -> ListB MenuItem -> GUI Menu
mkMenuL cs items = do
 m <- menu cs
 runMenuItems m items
 return m

-- make a menu popup or popdown based on an event
popupE :: Event (Maybe Point2) -> Conf Menu
popupE e = confGUI $ \w -> do
 addListenerW e (mkL $ popup w) w


-- make a menu popup or popdown based on an event
popupME :: Event Bool -> Conf Menu
popupME e = confGUI $ \w -> do
 addListenerW e (mkL $ popupM w) w


-- make a window use a menu
useMenu :: GUI Menu -> Conf Window
useMenu mk = confGUI $ \w -> do 
		m <- mk
		csetB w [use_menu m]
\end{code}

Display a dynamic list of menu items, using dispL

\begin{code}
runMenuItems :: Menu -> ListB MenuItem -> GUI ()
runMenuItems m items = do
 dispL lookupIdent (insert m) (reset m) delete  (move m) m items
 return ()
  where
    -- insert an item into the menu
    insert :: Menu -> MenuItem -> PlacePos MInfo -> GUI MInfo
    insert m mi pos = runMenuItem m (fmap fst pos) mi

    -- reset the whole list
    reset :: Menu -> [MInfo] -> [MenuItem] -> GUI [MInfo]
    reset m olds news = do
      liftIO $ mapM_ snd olds
      mapM (runMenuItem m PlaceBottom) news

    -- delete an item using the recorded remover
    delete :: MInfo -> GUI ()
    delete (_,rm) = liftIO $ rm

    -- move an item above another
    move :: Menu -> MInfo -> PlacePos MInfo -> GUI ()
    move m (id,_) pos = liftIO $ moveMItem (widgetPrim m) id (fmap fst pos)

-- we store the identifier and remove action for each item
type MInfo = (Ident,Remover)

-- find data for all items with a given index
lookupIdent :: Ident -> [(Ident,b)] -> [b]
lookupIdent a = mapMaybe (\(x,y) -> if a == x then Just y else Nothing)
\end{code}

 
-- Menu items -----------------------------------------------

Menu items are an abstract data type in FranTk

\begin{code}
data MenuItem = MenuButton [Conf MButton] (Listener ())
              | MenuCheckbutton [Conf MCheckbutton] (Listener Bool)
              | MenuRadiobutton [Conf MRadiobutton] (Listener ())
              | MenuCascade [Conf MCascade] (Menu -> GUI Menu) 
              | MenuSeparator

mbutton :: [Conf MButton] -> Listener () -> MenuItem
mcheckbutton :: [Conf MCheckbutton] -> Listener Bool -> MenuItem
mradiobutton :: [Conf MRadiobutton] -> Listener () -> MenuItem
mcascade :: [Conf MCascade] -> GUI Menu -> MenuItem
mseparator :: MenuItem

mbutton = MenuButton
mcheckbutton = MenuCheckbutton
mradiobutton = MenuRadiobutton
mcascade cs mk = MenuCascade cs (const mk) 
mseparator = MenuSeparator
\end{code}

make a menu item given a menu, position, creation function and list of configs,
returning the id of the menu and destroy action

\begin{code}
runItem :: WidgetItem w => Menu -> PlacePos Ident 
        -> (Menu -> [Conf w] -> PlacePos Ident -> GUI w) 
        -> [Conf w] 
        -> GUI (Ident,IO ())
runItem menu pos  mk cs = do
 w <- mk menu cs pos
 return (uniqueId w,destroy w)
\end{code}

display an abstract menu item

\begin{code}
runMenuItem :: Menu -> PlacePos Ident 
            -> MenuItem -> GUI (Ident,Remover)
runMenuItem menu pos  (MenuButton cs l) = do
 runItem menu pos  mbutton' $
   -- the listener hears button presses (see PrimWidget.lhs for more on 
   -- primActions 
   command (wrapIOL (primAction $ guiDef menu) l):cs
runMenuItem menu pos  (MenuCheckbutton cs l) = 
 runItem menu pos  mcheckbutton' $ 
   -- the checkbutton samples its own value on press and passes it to
   -- the listener
     commandSelf (liftIO . getMCheck) l:cs
runMenuItem menu pos  (MenuRadiobutton cs l) = 
 runItem menu pos  mradiobutton' $ 
   -- the listener hears button presses (see PrimWidget.lhs for more on 
   -- primActions 
    command (wrapIOL (primAction $ guiDef menu) l):cs
runMenuItem menu pos  (MenuSeparator) = 
 runItem menu pos  (\m c p -> mseparator' m p) []
runMenuItem menu pos  (MenuCascade cs mkm) = do
 mn <- mkm menu
 (id,rm) <- runItem menu pos  
              (\m c p -> do c <- mcascade' m mn cs p
			    return c
              ) cs
 return (id,rm)
\end{code}

Display a listbox, give it a list of items or a dynamic list of items
\begin{code}
mkListbox :: [Conf Listbox] -> Component
mkListbox = fmap widget . listbox

listItems :: [String] -> Conf Listbox
listItems xs = confIO $ \w -> resetListbox w xs

listItemsB :: Behavior [String] -> Conf Listbox
listItemsB b = confIO $ actB resetListbox b


-- display a dynamic list collection in a listbox
-- note that all listbox ops expect access to the numerical 
-- index of the list item. When performing a lookup we
-- therefore need to find the indices of each item
-- we also maintain the String at each location, for use when
-- moving item
listItemsLB :: ListB String -> Conf Listbox
listItemsLB items = confGUI $ \l -> do
 dispL lookupItem (insert l) (reset l) (delete l) (move l) l items
 return ()
  where
    lookupItem :: Ident -> [(Ident,(String,Int))] -> [(String,Int)]
    lookupItem i xs = 
       zip (map fst $ lookupIdent i xs) (findIndices ((== i) . fst) xs)

    insert :: Listbox -> String -> PlacePos (String,Int) -> GUI (String,Int)
    insert l li pos = liftIO $ fmap (const (li,0)) $ insertLBox l li $ fmap snd pos

    delete :: Listbox -> (String,Int) -> GUI ()
    delete l (_,n) = liftIO $ deleteLBox l n

    reset :: Listbox -> [(String,Int)] -> [String] -> GUI [(String,Int)]
    reset l _ xs = liftIO $ fmap (const $ zip xs [1..]) $ resetListbox l xs
 
    -- if the item was originally earlier in the list than its new
    -- location then deleting it will have altered the list order.
    -- To fix this we alter the location to be one earlier
    move :: Listbox -> (String,Int) -> PlacePos (String,Int) -> GUI ()
    move l (s,x) pos = liftIO $ do
	deleteLBox l x
        case pos of
          PlaceBefore (_,y) | y >= x -> insertLBox l s $ PlaceBefore (y-1)
	  PlaceAfter (_,y) | y >= x -> insertLBox l s $ PlaceAfter (y-1)
	  pos -> insertLBox l s $ fmap snd pos
\end{code}


Display a dynamic list of items given an insert, reset, delete and move action,
along with the widget and the list. We maintain local data for each item.
We pass in a lookup function that finds the info associated with an item,
given the identifier of the item and the list of items.
There shouldn't be more than one item with the same identifier, but just in 
case handle it by returning a list of info.

\begin{code}
dispL :: (WidgetItem w) => 
	       (Ident -> [(Ident,info)] -> [info])
            -> (a -> PlacePos info -> GUI info) 
            -> ([info] -> [a] -> GUI [info])
            -> (info -> GUI ())
            -> (info -> PlacePos info -> GUI ())
            -> w -> ListB a -> GUI ()
dispL lookupItems (renderItem :: a -> PlacePos info -> GUI info)
      resetItems deleteItem moveItem w items = do
 ls <- liftIO $ do t <- getFranTime
                   behaviorC items `at` t
 ref <- liftIO $ newIORef []
 place ref (ResetList ls)
 op <- mkGUIL $ place ref
 addListenerW (eventC items) op w
 return ()
  where
   fromPos :: [(Ident,info)] -> PlacePos Ident -> (PlacePos info)
   fromPos fm pos = 
                   case pos of 
                         PlaceBottom -> PlaceBottom
			 PlaceTop -> PlaceTop
		         PlaceBefore v ->
			     maybe PlaceTop (PlaceBefore) 
                                 $ listToMaybe $ lookupItems v fm
			 PlaceAfter v -> 
			     maybe PlaceBottom (PlaceAfter) 
                                 $ listToMaybe $ lookupItems v fm

   place :: IORef [(Ident,info)] -> ListOp a -> GUI ()
   place ref (InsertList ident a pos) = do
     pos' <- liftIO $ fmap (flip fromPos pos) $ readIORef ref 
     info <- renderItem a pos'
     liftIO $ updIORef ref $ \ls -> insertWith (ident,info) pos ls
     return ()
   place ref (DeleteList ident) = do
     fm <- liftIO $ readIORef ref
     case lookupItems ident fm of
      [] -> liftIO $ print "deleting non existent elt"
      infos -> do
	liftIO $ writeIORef ref $  filter (\ (n',_) -> n' /= ident) fm
	mapM_ deleteItem infos
   place ref (ResetList as) = do
     elts <- liftIO $ fmap (map snd) $ readIORef ref 
     case unzip $ fromList as of
      (is,as) -> do
       ms <- resetItems elts as
       liftIO $ writeIORef ref $ zip is ms
   place ref (MoveList id pos) = do
     fm <- liftIO $ readIORef ref
     case partition ((== id) . fst) fm of
      ([],as) -> return ()
      (xs,as) -> do
        let pos' = fromPos fm pos
	liftIO $ writeIORef ref $ foldl' (\as x -> insertWith x pos as) as xs
	mapM_ (flip moveItem pos') $ lookupItems id fm
\end{code}

Entry widget components.
\begin{code}
mkEntry' :: [Conf Entry] -> Component
mkEntry' cs = fmap widget $ entry cs

--There is a creation function which takes an event and listener, and sends out 
--the state of the entry when a value is heard on the event.

mkEntry :: [Conf Entry] -> Event () -> Listener String -> Component
mkEntry cs ev l = mkEntry' (snapEntry (\_ s -> s) ev l:cs)

--There is also a creation function that makes an entry that tells its argument 
--listener the value of the entry, every time the return key is pressed.

mkEntryRtrn :: [Conf Entry] -> Listener String -> Component
mkEntryRtrn cs l = do
 w <- mkWire
 keyPress Return (input w) $ mkEntry cs (event w) l
\end{code}

We can sample the value of a text area using snapEntry. Given an event, a listener 
and a composition function we can set up a sampling function. When a value is heard 
on the event, the state of the entry is sampled. The value is composed with the 
String from the entry, using the composition function, and is then told to the 
listener.

\begin{code}
snapEntry :: (a -> String -> b) -> Event a -> Listener b -> Conf Entry
snapEntry f ev l = confGUI $ \ent -> do
 addListenerW ev (mapIOL (\a -> do
			s <- getEntry ent
			return (f a s)) l) ent
 return ()
\end{code} 

-- The Edit widget ---------------------------

make an edit component and a scrollable edit component

\begin{code}

mkEdit :: [Conf Edit] -> Component
mkEdit cs = fmap widget $ edit cs
 
mkScrollableEdit :: [Conf Edit] -> [Conf Scrollbar] -> [Conf Scrollbar] 
                 -> Component
mkScrollableEdit cs hs vs = do
 v <- mkVScroll
 h <- mkHScroll
 (mkEdit ([useScroll v,useScroll h] ++ cs) 
  `beside` 
  (fill FillY $ mkVScrollbar $ [useScroll v] ++ vs))
  `above`
  (fill FillX $ mkHScrollbar $ [useScroll h] ++ hs)
\end{code}

We can snapshot the complete current text of the edit widget with snapEdit

\begin{code}

snapEdit :: (a -> String -> b) -> Event a -> Listener b -> Conf Edit
snapEdit f ev l = confGUI $ \ed -> do
 addListenerW ev (mapIOL (\a -> do
			s <- getEdit ed
			return (f a s)) l) ed
 return ()

\end{code}



Edit widgets have access to the clipboard, to copy cut and paste current
selection
\begin{code}
data ClipboardAction = Copy | Cut | Paste 

clipboardE :: Event ClipboardAction -> Conf Edit
clipboardE e = confGUI $ \w -> do
 addListenerW e (mkL $ handle w) w
  where
   handle w Copy = copyClip w
   handle w Cut = cutClip w
   handle w Paste = pasteClip w
\end{code}


As well as setting the edit widget using text configuration,
we can also set the edit widget with structured text. This allows:
1) standard text
2) tagged text which represent subsections of text, which can be activated
   individually, for example, to make hyperlinks for example.
3) Marks added to text which mark specific points in the text

We can do this through the EditVal data type

There are number of functions to construct values of type EditVal. We can insert text at a given point (insertEditVal), delete text between two given points (deleteEditVal), reset the text (resetEditVal), or clear it (clearEditVal).

We can insert an EditMark, or an EditTag. An EditMark puts a mark at particular point in some text. An EditTag is a way of tagging, and therefore changing the attributes of some section of text. 

We can also insert some text at a given point, with an EditTag associated with.

Note that a given EditTag or EditMark can only be added to a single edit widget. This is why we pass in a value of type GUI EditTag (or EditMark), which is an action that produces an EditTag (or EditMark).


\begin{code}


-- Add structured text consisting of a list of structured items
-- These can be standard text, tagged structured text (note this is
-- recursive, allowing us tags within tags), and marks.

data Structured = SText String
		| SGroup [Structured]
		| STextTagged [Structured] (GUI EditTag) 
		| STextMark (GUI EditMark)
 deriving Show


structured :: Structured -> IDoc
structured s = [ResetStructured noEdit s]

insertStructured :: Structured -> TIndex -> IDoc -> IDoc
insertStructured s t idocs = InsertStructured noEdit s t : idocs

replaceStructured :: Structured -> Ident -> IDoc -> IDoc
replaceStructured s i idocs = ReplaceStructured noEdit s i : idocs

emptyIDoc :: IDoc
emptyIDoc = structured $ SText ""

fromStringIDoc :: String -> IDoc
fromStringIDoc s = structured $ SText s

insertIDoc :: String -> TIndex -> IDoc -> IDoc
insertIDoc s t i = insertStructured (SText s) t i

resetIDoc :: String -> IDoc -> IDoc
resetIDoc s _ = fromStringIDoc s 

clearIDoc :: IDoc -> IDoc
clearIDoc _ = emptyIDoc

deleteIDoc :: TIndex -> TIndex -> IDoc -> IDoc
deleteIDoc t1 t2 idocs = DeleteBetween noEdit t1 t2 : idocs


insertTagIDoc :: GUI EditTag -> IDoc -> IDoc
insertTagIDoc g x = InsertEditTag nullId g : x

insertMarkIDoc :: GUI EditMark -> IDoc -> IDoc
insertMarkIDoc g x = InsertEditMark nullId g : x

deleteFrom :: TIndex -> Int -> IDoc -> IDoc
deleteFrom t n i = deleteFrom' noEdit t n : i

deleteFrom' :: Ident -> TIndex -> Int -> DocUpd
deleteFrom' ed i n = 
   if n < 0 then DeleteBetween ed (TModMove i (ModChars n)) i
   else          DeleteBetween ed i (TModMove i (ModChars n))
\end{code}

\begin{code}

type IDoc = [DocUpd]

data DocUpd = InsertStructured Ident Structured TIndex
            | ReplaceStructured Ident Structured Ident
	    | ResetStructured Ident Structured
	    | DeleteBetween Ident TIndex TIndex


	     | InsertEditMark Ident (GUI EditMark)
	     | InsertEditTag Ident (GUI EditTag)
	     -- these last two are used by edit widgets when translating
	     -- user input into edit val updates.
	     | SetMark Ident (Maybe TIndex) Ident
	     | SetTag Ident (Maybe (TIndex,TIndex)) Ident
 deriving Show

noEdit :: Ident
noEdit = nullId

editId :: DocUpd -> Ident
editId (InsertStructured id _ _) = id
editId (ReplaceStructured id _ _) = id
editId (ResetStructured id _) = id
editId (DeleteBetween id _ _) = id
editId (InsertEditMark id _) = id
editId (InsertEditTag id _) = id
editId (SetMark id _ _) = id
editId (SetTag id _ _) = id

instance Show (GUI a) where
 show a = "<GUI>"
\end{code}

\begin{code}

data DocumentB = DocumentB {
	docBInit :: IDoc,
	docBEvent :: Event IDoc,
	docBBehavior :: Behavior EditState
       }

data DocumentBVar = DocumentBVar {
	docB :: DocumentB,
	docBVarUpdInput :: Listener (IDoc -> IDoc)
	}

-- currently we're not implementing updates to the edit state properly
-- so we just make an initial list of edit val updates and then apply them
-- to the widget

data EditState = EditState {
	editmarks :: IDoc, -- updates to add marks
	editState :: [EditEntry] -- the state of the edit widget
	}

data EditEntry = EditText String | EditMark Ident 
               | EditTagStart Ident | EditTagStop Ident


emptyEditState :: EditState
emptyEditState = EditState [] [] 

\end{code}

Configuration options for using Document behaviors

\begin{code}
useDocBVar :: DocumentBVar -> Conf Edit 
useDocBVar docbv = composeConf (listenDoc (docBVarUpdInput docbv))	
			       (setDocB (docB docbv))


setDocB :: DocumentB -> Conf Edit
setDocB = confGUI . setDocBGUI


listenDoc :: Listener (IDoc -> IDoc) -> Conf Edit
listenDoc = confGUI . listenDocGUI

updIDoc :: (IDoc -> IDoc) -> Conf Edit
updIDoc = confGUI . setIDocGUI

setIDoc :: IDoc -> Conf Edit
setIDoc xs = updIDoc $ \_ -> xs ++ emptyIDoc

setIDocE :: Event (IDoc -> IDoc) -> Conf Edit
setIDocE = confGUI . setDocEGUI

setIDocB :: Behavior IDoc -> Conf Edit
setIDocB b = confGUI $ \w -> setB' (\_ _ -> False) w setIDoc b

\end{code}


\begin{code}

mkDocumentBVar :: IDoc -> GUI DocumentBVar
mkDocumentBVar init = do
 w <- mkWire
 b <- mkDocumentB init (event w)
 return $ DocumentBVar b (input w)

mkDocumentB :: IDoc -> Event (IDoc -> IDoc) -> GUI DocumentB
mkDocumentB init e = liftIO $ mkDocumentB' init emptyEditState e

mkDocumentB' :: IDoc -> EditState -> Event (IDoc -> IDoc) -> IO DocumentB
mkDocumentB' init st e =  do
 ev <- F.accumE init (e ==> \f _ -> reverse (f []))
 bh <- F.stepAccum st (ev ==> \is e -> foldr applyEditState e is)
 return $ DocumentB init ev bh

applyEditState :: DocUpd -> EditState -> EditState
applyEditState ins@(InsertEditMark _ _) st@(EditState marks _) =
 st {editmarks = ins:marks}
applyEditState ins@(InsertEditTag _ _) st@(EditState marks _) = 
 st {editmarks = ins:marks}
applyEditState ins@(SetMark _ _ _) st@(EditState marks _) = 
 st {editmarks = ins:marks}
applyEditState ins@(SetTag _ _ _) st@(EditState marks _) = 
 st {editmarks = ins:marks}
applyEditState e st = st 
\end{code}


\begin{code}

setDocEGUI :: Event (IDoc -> IDoc) -> Edit -> GUI ()
setDocEGUI e w = do
 ref <- liftIO $ newIORef []
 runIDocEvent (mapE (reverse . ($ [])) e) w ref

setDocBGUI :: DocumentB -> Edit -> GUI ()
setDocBGUI (DocumentB inits e b) w = do
 (EditState mrks s) <- liftIO $ getFranTime >>= at b
 ref <- liftIO $ newIORef []
 mapM_ (fromDocUpd ref w) $ inits ++ reverse mrks
 runIDocEvent e w ref

setIDocGUI :: (IDoc -> IDoc) -> Edit -> GUI ()
setIDocGUI i e = do
 ref <- liftIO $ newIORef []
 setIDocG (reverse $ i []) e ref

\end{code}


we can insert IDoc updates into an edit widget using fromDocUpd
and using runEditVal to insert an event list of them

\begin{code}

setIDocG :: IDoc -> Edit -> IORef StructuredData -> GUI ()
setIDocG xs e ref = do
 liftIO $ resetEdit e ""
 mapM_ (fromDocUpd ref e) xs

runIDocEvent :: Event IDoc -> Edit -> IORef StructuredData -> GUI ()
runIDocEvent e ed ref = do
 gl <- mkGUIL $ mapM_ (fromDocUpd ref ed)
 addListenerW e gl ed
 return ()

-- a list of trees. We maintain a copy of the tree, and a list
-- of all the identifiers in each tree.
type StructuredData = [TreeIO (Ident,IO ())]

fromDocUpd :: IORef StructuredData -> Edit -> DocUpd -> GUI ()

fromDocUpd ref ed x | uniqueId ed == editId x = return ()
fromDocUpd ref ed (DeleteBetween edid i1 i2) = liftIO $ 
 deleteEdit ed i1 i2

fromDocUpd ref ed (InsertStructured _ xs i) = do
 pre <- liftIO $ readIORef ref
 ts <- doStructured ed xs i []
 ts <- liftIO $ mapM initTreeIO ts
 liftIO $ writeIORef ref $ ts ++ pre

fromDocUpd ref ed (ResetStructured nid s) = do 
 liftIO $ resetEdit ed ""
 ts <- doStructured ed s tindexStart []
 ts <- liftIO $ mapM initTreeIO ts
 liftIO $ writeIORef ref $ ts 

fromDocUpd ref ed (ReplaceStructured nid x idold) = do
 pre <- liftIO $ readIORef ref
 add pre
  where
   add :: [TreeIO (Ident,IO ())] -> GUI ()
   add (t:ts) = do
    (mb,dead,abv) <- liftIO $ replaceInTree ((== idold) . fst) t
    case mb of
      Nothing -> add ts
      Just op -> do
        i1' <- liftIO $ fromTIndex ed (tindexTagFirst idold)
        case i1' of
         (Just (x1,y1)) -> do 
           liftIO $ deleteEdit ed (tindex x1 y1) (tindexTagLast idold)
           liftIO $ mapM_ snd dead
           sts <- doStructured ed x (tindex x1 y1) (map fst abv)
           case sts of
            (st:_) -> liftIO $ op st
            _ -> return ()
         Nothing -> return ()

fromDocUpd ref ed (InsertEditMark edid gui) = do
      mrk <- gui
      liftIO $ addEditMark mrk ed
fromDocUpd ref ed (InsertEditTag edid gui) = do
      tg <- gui
      liftIO $ addEditTag tg ed      
fromDocUpd ref ed (SetMark edid i m) = 
      liftIO $ mark ed m i >> return ()
fromDocUpd ref ed (SetTag edid mb i) =
      liftIO $ setTag' ed i mb 

\end{code}

-- add structured text, associating with each individual bit of text
-- all the parent tags in ts, as well as any provided by Structured

-- Why? Tcl-tk has the rule that when inserting text it only retains 
-- the tags that cover text on both the left and right side of the 
-- insertion position. If you're replacing text and want to insert
-- the new text inside all the tags the old text was in, and you're doing this
-- at the beginning or end of the tag it won't work. So we can pass
-- in a list of tags that the old text was in instead.

\begin{code}

doStructured :: Edit -> Structured -> TIndex -> [Ident] -> GUI [SubTree (Ident,IO ())]
doStructured ed xs i ts = do
 let i' = if i == TIndexEnd then TModMove i (ModChars (-1)) else i
 liftIO $ setMark' ed (identify "tmpmark") (Just $ i')
 ts <- handle xs
 liftIO $ setMark' ed (identify "tmpmark") Nothing
 return ts
  where
    mpos = tindexMark (identify "tmpmark")

    handle ::  Structured -> GUI [SubTree (Ident,IO ())]
    handle st@(SText s) = do
      liftIO $ insertEditTagged ed mpos s ts
      return []
    handle (STextMark mkmrk) = do 
	mrk <- mkmrk
	liftIO $ do
  	 setEditMarkIndex mrk (Just mpos) 
	 addEditMark mrk ed
        return []
    handle st@(STextTagged xs mktg) = do
	tg <- mktg 	
	(x,y) <- fmap (maybe (1,0) id) $ liftIO $ fromTIndex ed mpos
	liftIO $ addEditTag tg ed  
	cs <- fmap concat $ mapM handle xs
	liftIO $ setEditTagIndex tg (Just (tindex x y,mpos))
        return $! [SubTree (uniqueId tg,destroy tg) cs]
    handle st@(SGroup xs) =
      fmap concat $ mapM handle xs

\end{code}

This edit listener implementation uses some general mechanisms but is fairly tcl
specific. Not sure how specific yet though.

\begin{code}

listenDocGUI :: Listener (IDoc -> IDoc) -> Edit -> GUI ()
listenDocGUI l' ed = do

 let l :: Listener DocUpd
     l = comapL (:) l'

 -- record what modifiers are currently pressed
 -- as we don't hear some text when control or alt is pressed
 active <- mkBVar []

 -- record the current selection. We can use this then for delete actions.
 -- as behaviors get updated immediately after the event, on a given input,
 -- this will be the selection status immediately before the event
 selection <- mkBVar Nothing

 -- the actual selection status, this will change with user input.
 -- and so is the selection status immediately after the input
 sel <- selectEditTag []
 liftIO $ addEditTag sel ed

 -- the insertion mark. again its state after the input has been applied.
 ins <- insertEditMark
 liftIO $ addEditMark ins ed

 -- we pass on an insertion mark and tag to the edit valB. This represents
 -- the mark and selection area of this widget in the shared state.
 n <- getUniqueName
 let otherins = identify $ "ins" ++ show n
 let othersel = identify $ "sel" ++ show n

 liftIO $ do 
  send <- fireListener l
  send $ InsertEditMark edid (mkEditMark [useIdent otherins])

  send $ InsertEditTag edid (mkEditTag [useIdent othersel])
 
 -- when the selection state changes pass on the new selection value to
 -- the shared edit state.

 addListenerW (event selection) (comapL (flip (SetTag edid) othersel) l) ed

 -- get the index of the insertion cursor
 let getIndx :: IO (Maybe TIndex)
     getIndx = fmap (fmap (uncurry TIndex)) $ getEditMarkIndex ins

 -- get the indices of the selection tag
 let getSelIndx :: IO (Maybe (TIndex,TIndex))
     getSelIndx = fmap (fmap toTIndex) $ getEditTagIndex sel

 -- when we hear some input that may have changed the selection
 -- we sample the old selection (from the BVar), and the new selection
 -- from the tag. If they differ update the BVar.
 let select :: Listener a
     select = snapshotL_ (bvarBehavior selection) $
		  mapMaybeIOL (\oldsel -> do 
				  newsel <- getSelIndx
				  if oldsel /= newsel then 
				    return $ Just newsel
				   else return Nothing)
		  (input selection)

 -- when we hear a key press. sample the modifier state, and selection state.
 -- also sample the actual insertion cursor and selection cursor.
 -- then make an update message using fromKeyL based on the key and all this info 
 let keyMessage :: Listener Key
     keyMessage =
      snapshotL (pairB (bvarBehavior active) (bvarBehavior selection))
	(mapIOL (\k -> do x <- getIndx
			  newsel <- getSelIndx
			  return (k,x,newsel)) $ 
	   mapL (\ k eds -> reverse (fromKeyL otherins (tindexMark otherins) k)
		            ++ eds) 
		 l')

 -- when we get a button 1 press update the insertion cursor position
 mousePress 1 (mapIOL (const $ fmap (flip (SetMark edid) otherins) $ getIndx) 
		      l) $
  -- when button 1 is released we have probably updated the selection
  mouseRelease 1 select $

  -- on a key press we do several things, send an update message saying the text
  -- may have changed with keyMessage, update the selection, and update the 
  -- modifier key state
  keyPressAny (keyMessage
	       `mergeL`
	         select
	       `mergeL`
		(mapMaybeL setInactive (bvarUpdInput active))) $
  -- when the Alt or Control key is released update the modifer key state.
  keyRelease Alt (tellL (bvarUpdInput active) (delete Alt)) $
  keyRelease Control (tellL (bvarUpdInput active) (delete Control)) $
	     (return ed)
 return ()
  where
   -- the unique identifier of the edit widget. We pass this along with all
   -- messages so that when sharing we know if the update was sent by
   -- this widget
   edid :: Ident
   edid = uniqueId ed

   -- if a modifier key is pressed update the modifier state
   setInactive :: Key -> Maybe ([Key] -> [Key])
   setInactive Alt = Just $ insertOrd cmp const Alt
   setInactive Control = Just $ insertOrd cmp const Control
   setInactive _ = Nothing

   -- compare two keys for ordering, if they're not equal, keep searching
   cmp :: Key -> Key -> Ordering
   cmp a b = if a == b then EQ else GT

   -- converting a keypress into an update
   fromKeyL :: Ident -- the shared insertion tag's identifier
            -> TIndex -- the index associated with this shared insertion tag
            -> ((Key, -- the key pressed
                 ([Key], -- the modifier state
                  Maybe (TIndex,TIndex))), 
                    -- the selection indices immediately before this key press
                Maybe TIndex,
                    -- the actual insertion cursor position after key press
                Maybe (TIndex,TIndex))
                    -- the actual selection indices after key press
            -> [DocUpd] -- the updates we generate
   fromKeyL oins oinsM ((v,(mods,sel)),ti,newsel) = 
     catMaybes [fromDel oinsM v sel mods, -- generate deletes
     	        if null mods then fromKey oinsM v else Nothing, -- insert text
		fromMod oins v sel ti] -- change our mark in the shared mark
 
   -- generate a delete update
   fromDel :: TIndex  -- the index associated with our shared insertion tag
           -> Key -- the key pressed
           -> Maybe (TIndex,TIndex) 
                      -- the selection indices immediately before this key press
           -> [Key] -- the modifier state
           -> Maybe DocUpd
   -- on a delete press if there is a selection delete it otherwise delete the 
   -- next character
   fromDel oinsM Delete sel _ = Just $ maybeDel oinsM sel 1
   -- on a backspace if there is a selection delete it otherwise delete the 
   -- last character
   fromDel oinsM BackSpace sel _ = Just $ maybeDel oinsM sel (-1)
   -- if there is a selection, and we pressed an actual character 
   -- without a modifier on delete the selection
   fromDel _ v sel [] | isInsertDels v  = 
	fmap (uncurry $ DeleteBetween edid) sel 
   -- otherwise delete nothing
   fromDel _ _ _ _ = Nothing

   -- an actual character ie real text to be inserted
   isInsertDels :: Key -> Bool
   isInsertDels v = v `elem` [Tab,Return,Space] || 
		    (case v of KeyChar _ -> True
			       Key _ -> True
			       _ -> False)

   -- when we hear a delete if there is a selection delete it
   -- otherwise delete starting from our cursor for some number of characters
   maybeDel :: TIndex -- the index associated with our shared insertion tag
            -> Maybe (TIndex,TIndex) 
                      -- the selection indices immediately before this key press
            -> Int -- some distance worth of characters to delete 
                   -- (negative means backwards)
            -> DocUpd
   maybeDel oinsM sel n = 
	maybe (deleteFrom' edid oinsM n) 
	      (uncurry $ DeleteBetween edid) sel

   -- is the key a movement key, changing the cursor position but not inserting
   -- text
   isMover :: Key -> Bool
   isMover v = v `elem` movers
    where
     movers :: [Key]
     movers = [Home,End,CursorLeft,CursorRight,CursorUp,CursorDown,Next,Prior]

   -- change our shared insertion cursor in the DocumentB state
   fromMod :: Ident -- the identifier associated with our shared insertion cursor
           -> Key -- the key pressed
           -> Maybe (TIndex,TIndex) 
                      -- the selection indices immediately before this key press
           -> Maybe TIndex 
                -- the actual insertion cursor position after key press
           -> Maybe DocUpd
   -- if there was a movement character or there was just some selected text
   -- then our cursor has probably moved.
   -- if so then set the new position of the cursor
   -- it is assumed that marks will move about sensibly in the edit val state
   -- and in edit widgets without needing to send explicit updates
   fromMod oins v sel ti | isMover v || isJust sel = 
    Just $ SetMark edid ti oins
   fromMod _ _ _ _ = Nothing

   -- when we hear a key, if it represents textual input, such as tabs, return keys,
   -- or a character send an insertion request to insert the String equivalent,
   -- at our insertion cursor
   fromKey :: TIndex -- the index associated with our shared insertion cursor
           -> Key -- the key pressed
           -> Maybe DocUpd
   fromKey oinsM Tab = Just (insertString edid oinsM "\t")
   fromKey oinsM Return = Just (insertString edid oinsM "\n")
   fromKey oinsM (KeyChar c) = Just (insertString edid oinsM [c])
   fromKey oinsM (Key s) = Just (insertString edid oinsM s)
   fromKey oinsM Space = Just (insertString edid oinsM " ")
   fromKey _ k = Nothing


   insertString :: Ident -> TIndex -> String -> DocUpd
   insertString i t s = InsertStructured i (SText s) t

\end{code}

introduce selections properly

setSelection :: Maybe (TIndex,TIndex) -> IDoc
getSelection :: IDoc -> Maybe (Maybe (TIndex,TIndex))
getSelectedTags :: IDoc -> Maybe ([Ident],[Ident])
but prefer
getSelectedTags :: IDoc -> Maybe [Ident]

selection :: [Conf EditTag] -> Selection
instance Has_Input Selection
TIndex -> (Int,Int) 
TIndex -> [Ident]

sampling the indices of a mark with a listener or event

\begin{code}
snapMarkE :: Event a -> EditMark -> Event (a, Maybe (Int,Int))
snapMarkE e edi = F.withIOE e (\v -> do t <- getEditMarkIndex edi;return (v,t))  

snapMarkE_ :: Event a -> EditMark -> Event (Maybe (Int,Int))
snapMarkE_ e edi = snapMarkE e edi ==> snd

snapMarkL :: EditMark -> Listener (a,Maybe (Int,Int)) -> Listener a
snapMarkL edi l = 
 mapIOL (\v -> do t <- getEditMarkIndex edi;return (v,t)) l

snapMarkL_ :: EditMark -> Listener (Maybe (Int,Int)) -> Listener a
snapMarkL_ edi l =
 snapMarkL edi $ mapL snd l
\end{code}

sampling the indices of a tag with a listener or event
\begin{code}
snapTagE :: Event a -> EditTag -> Event (a, Maybe((Int,Int),(Int,Int)))
snapTagE e edi = F.withIOE e (\v -> do t <- getEditTagIndex edi;return (v,t))  

snapTagE_ :: Event a -> EditTag -> Event (Maybe((Int,Int),(Int,Int)))
snapTagE_ e edi = snapTagE e edi ==> snd

snapTagL :: EditTag -> Listener (a,Maybe ((Int,Int),(Int,Int))) -> Listener a
snapTagL edi l = 
 mapIOL (\v -> do t <- getEditTagIndex edi;return (v,t)) l

snapTagL_ :: EditTag -> Listener (Maybe ((Int,Int),(Int,Int))) -> Listener a
snapTagL_ edi l =
 snapTagL edi $ mapL snd l
\end{code}


\begin{code}
instance Has_Input (GUI Edit) where
 bindAction a l w = do w <- w;liftIO $ bind w a l;return w
\end{code}

Deprecated functions

\begin{code}

type EditVal = DocUpd

insertEditVal :: String -> TIndex -> EditVal
insertEditVal s t = InsertStructured noEdit (SText s) t 

deleteEditVal :: TIndex -> TIndex -> EditVal
deleteEditVal t1 t2 = DeleteBetween noEdit t1 t2

resetEditVal :: String -> EditVal
resetEditVal = ResetStructured noEdit . SText

clearEditVal :: EditVal
clearEditVal = resetEditVal ""

insertTagEditVal :: GUI EditTag -> EditVal
insertTagEditVal = InsertEditTag nullId

insertMarkEditVal :: GUI EditMark -> EditVal
insertMarkEditVal = InsertEditMark nullId

-- We can also insert some text at a given point, with an EditTag 
-- associated with.
insertTaggedEditVal :: String -> TIndex -> GUI EditTag -> EditVal
insertTaggedEditVal s ti g = 
 InsertStructured nullId (STextTagged [SText s] g) ti 

insertStructuredEditVal :: [Structured] -> TIndex -> EditVal
insertStructuredEditVal s t = InsertStructured nullId  (SGroup s) t

replaceStructuredEditVal :: Structured -> Ident -> EditVal
replaceStructuredEditVal = ReplaceStructured nullId

editValsB :: Behavior [EditVal] -> Conf Edit
editValsB = setIDocB

type EditValB = DocumentBVar
type EditValBehavior = DocumentB

editValEvent :: EditValB -> Event EditVal
editValEvent = mapEs reverse . docBEvent . docB

editValInput :: EditValB -> Listener EditVal
editValInput = comapL (:) . docBVarUpdInput

editValB :: EditValB -> Conf Edit
editValB = setDocB . docB

editVals :: [EditVal] -> Conf Edit
editVals = setIDoc

editValL :: Listener EditVal -> Conf Edit
editValL l = listenDoc $ comapLs (\f -> reverse $ f []) l

editValE :: Event EditVal -> Conf Edit
editValE = setIDocE . mapE (:)

useEditValBehavior :: EditValBehavior -> Conf Edit
useEditValBehavior = setDocB

-- initially reset the text area with the given text
initEditState :: String -> EditState
initEditState s = EditState [resetEditVal s] []

initEditVals :: [EditVal] -> EditState
initEditVals es = EditState (reverse es) []

-- make an edit val state in the GUI monad
mkEditValB :: EditState -> GUI EditValB
mkEditValB init = liftIO $ newEditValB init

-- make an edit val state, very like a dynamic collection
newEditValB :: EditState -> IO EditValB
newEditValB init@(EditState is _) = do
 w <- newWire
 b <- mkDocumentB' [] init (event w)
 return  $ DocumentBVar b (input w)

editValBehavior :: [EditVal] -> Event EditVal -> EditValBehavior
editValBehavior init e = DocumentB init (e ==> \x -> [x]) (lift0 emptyEditState)


\end{code}