Mercurial > gui
changeset 6:f17b869fbb71
Shifting some generic theme navigation menu code to the library.
| author | Karn Kallio <kkallio@eka> |
|---|---|
| date | Tue, 26 Apr 2011 20:27:04 -0430 |
| parents | 4385bc6a0d2d |
| children | 48a4180171b0 |
| files | examples/popup.ur examples/popup.urp examples/popup.urs lib.urp navbar.ur navbar.urs popupNav.ur popupNav.urs |
| diffstat | 8 files changed, 259 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/popup.ur Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,40 @@ +open Navbar +open PopupNav + +val testNav = navAdd (mkNavItem "item 2" (bless "http://item2.org")) + (navAdd (mkNavItem "item 1" (bless "http://item1.org")) + emptyNavBar) + +val testNav' = navAdd (mkNavItem "item 3" (bless "http://item3.org")) + testNav + +val otherFormat = {FormatMenu = fn ctl menu => <xml><h3>A Custom {ctl} Format</h3><ul>{menu}</ul></xml>, + OpenCtl = fn behaviour => <xml><a href={bless "http://#"} onclick={behaviour}>View</a></xml>, + CloseCtl = fn behaviour => <xml><a href={bless "http://#"} onclick={behaviour}>Hide</a></xml>} + + +fun main () = + + defaultFormatPopUp <- create defaultFormat testNav'; + otherFormatPopUp <- create otherFormat testNav'; + + return <xml> + <head> + <title>Navbar Based Popup Navigation.</title> + </head> + <body> + <h1>Example of using Navbar to build a widget.</h1> + <p> + This is a widget which generates a popup list + of links. + </p> + <h2>Example of the default format.</h2> + <p> + {render defaultFormatPopUp} + </p> + <h2>Example of another format.</h2> + <p> + {render otherFormatPopUp} + </p> + </body> + </xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/popup.urp Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,7 @@ +path META=../../meta +library ../ +rewrite url Popup/* +allow url http://* +prefix http://localhost:8080/ + +popup
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/popup.urs Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/lib.urp Thu Feb 10 12:39:20 2011 -0500 +++ b/lib.urp Tue Apr 26 20:27:04 2011 -0430 @@ -7,3 +7,6 @@ select forms datebox +navbar +popupNav +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/navbar.ur Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,85 @@ +style active +style last + +datatype navItem = NavItem of string * url + +datatype navBar m = NavBar of (list navItem) * (list navItem) +(* First list is items before the active item, second list is items at and after the active one. + * If the second list is non-empty its head is the active item. Parameter mode is to avoid + * double reverses coming from calling printingNavBar. *) + +type build = unit +type print = unit + +class mode t = navBar t -> xbody + +(* The case of special treatment for the last one seems common in themes. *) +fun mapXLast [a ::: Type] [ctx ::: {Unit}] (f : a -> bool -> xml ctx [] []) (ls : list a) : (xml ctx [] []) = + let + fun mapXLast' ls = + case ls of + [] => <xml/> + | x :: [] => <xml>{f x True}</xml> + | x :: ls => <xml>{f x False}{mapXLast' ls}</xml> + in + mapXLast' ls + end + +fun navItemToXml css (NavItem (text, url)) = + case css of + None => <xml><a href={url} title={text}>{[text]}</a></xml> + | Some cl => <xml><a class={cl} href={url} title={text}>{[text]}</a></xml> + +fun navBarToXml' (NavBar (before, after)) = + let + fun navListToXml checkForLast = + mapXLast (fn navItem lst => + let + val linkXml = navItemToXml None navItem + in + if checkForLast && lst then + <xml><li class={last}>{linkXml}</li></xml> + else + <xml><li>{linkXml}</li></xml> + end) + in + case after of + [] => <xml>{navListToXml True before}</xml> + | act :: tl => + <xml> + {navListToXml False before} + {case tl of + [] => <xml><li class={last}>{navItemToXml (Some active) act}</li></xml> + | _ => + <xml> + <li>{navItemToXml (Some active) act}</li> + {navListToXml True tl} + </xml>} + </xml> + end + +fun printingNavBar (NavBar (before, after)) = + NavBar (List.rev before, List.rev after) + +fun navBarToXml [t ::: Type] (m : mode t) = m + +fun navToXml_build (n : navBar build) : xbody = + navBarToXml' (printingNavBar n) + +fun navToXml_print (n: navBar print) : xbody = + navBarToXml' n + +val emptyNavBar = NavBar ([], []) + +fun mkNavItem text url = + NavItem (text, url) + +fun navAdd navItem navBar = + case navBar of + NavBar (before, []) => NavBar (navItem :: before, []) + | NavBar (before, after) => NavBar (before, navItem :: after) + +fun navAddActive navItem navBar = + case navBar of + NavBar (before, []) => NavBar (before, navItem :: []) + | NavBar (before, after) => NavBar (List.append after before, navItem :: [])
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/navbar.urs Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,52 @@ +(* NAVBAR provides services to construct and pretty print to xml typical + * menu items (of a visible text and a url link) and menu bars assembled + * from them. It is intended to be used as a low-level component in + * constructing navigation related widgets and theme parts. *) + +type navItem +(* Items in the navigation menu. *) + +con navBar :: Type -> Type +(* A menu bar of navigation links. Up to one link may be active. *) + +type build +type print +(* These track the current navbar mode. *) + +class mode +(* To make sure we always print the navbar correctly. *) + +val navToXml_build : mode build +val navToXml_print : mode print +(* How to print both modes. *) + +val printingNavBar : navBar build -> navBar print +(* This switches the navbar from building mode to printing mode. Normally not + * necessary to call this, but is in the signature in case the programmer will + * pass the same navbar to several components wanting to print it. Then by + * using this first multiple (redundant) calls to List.rev can be avoided. + * Mode tracking makes this optimization safe. *) + +val emptyNavBar : navBar build +(* An empty menu bar. *) + +val mkNavItem : string -> url -> navItem +(* Make a menu item with visible text given by the string and linking to url. *) + +val navAdd : navItem -> navBar build -> navBar build +(* Add an unactive item to the right end of the navbar. *) + +val navAddActive : navItem -> navBar build -> navBar build +(* Add an active item to the right end of the navbar. If there already + * was an active item it will be deactivated. *) + +val navItemToXml : option css_class -> navItem -> xbody +(* Pretty print a navItem with an optional style to a piece of <a>...</a> xml. *) + +val navBarToXml : t ::: Type -> mode t -> navBar t -> xbody +(* Pretty print the navigation menu as a piece of xml made of + * a chain <li><a>...</a></li> repeated. *) + +style active +style last +(* CSS classes to mark the active and last menu item. *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/popupNav.ur Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,42 @@ +datatype menuState = Open | Closed + +type formatCtl = {FormatMenu : xbody -> xbody -> xbody, + OpenCtl : transaction unit -> xbody, + CloseCtl : transaction unit -> xbody} + +val defaultFormat = {FormatMenu = fn ctl menu => <xml>{ctl}<ul>{menu}</ul></xml>, + OpenCtl = fn behaviour => <xml><button value="Open" onclick={behaviour}/></xml>, + CloseCtl = fn behaviour => <xml><button value="Close" onclick={behaviour}/></xml>} + +open Navbar + +con popupNav t = {MenuState : source menuState, + FormatCtl : formatCtl, + NavBar : navBar t} + +fun create [t ::: Type] (f : formatCtl) (m : mode t) (bar : navBar t) : transaction (popupNav t) = + state <- source Closed; + + return {MenuState = state, + FormatCtl = f, + NavBar = bar} + +fun render [t ::: Type] (m : mode t) (popup : popupNav t) = + popup.FormatCtl.FormatMenu + <xml> + <dyn signal={c <- signal popup.MenuState; + return + (case c of + Open => <xml>{popup.FormatCtl.CloseCtl (set popup.MenuState Closed)}</xml> + | Closed => <xml>{popup.FormatCtl.OpenCtl (set popup.MenuState Open)}</xml>) + }/> + </xml> + + <xml> + <dyn signal={c <- signal popup.MenuState; + return + (case c of + Open => <xml>{navBarToXml popup.NavBar}</xml> + | Closed => <xml/>) + }/> + </xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/popupNav.urs Tue Apr 26 20:27:04 2011 -0430 @@ -0,0 +1,29 @@ +(* POPUPNAV provides a simple navigation menu which opens and + * closes when the user clicks on an associated control. *) + +con popupNav :: Type -> Type +(* The type of popping open navigation menus. *) + +type formatCtl = {FormatMenu : xbody -> xbody -> xbody, + (* Allows for formatting the menu. The first two parameters + * represent "holes" for the control and menu items and + * the result should be the desired menu xml. The controls + * can be formatted with the options below, and the menu items + * will be placed as a chain of <li><a> ....</a></li>. *) + + OpenCtl : transaction unit -> xbody, + (* This should accept the transaction representing the opening of + * the menu and produce an xml control having this as action. *) + + CloseCtl : transaction unit -> xbody} + (* This should accept the transaction representing the closing of + * the menu and produce an xml control having this as action. *) + +val defaultFormat : formatCtl +(* Some reasonable default formats for the menu layout and controls. *) + +val create : t ::: Type -> formatCtl -> Navbar.mode t -> Navbar.navBar t -> transaction (popupNav t) +(* Given instructions for formatting the display and a navbar, get a popup navigation. *) + +val render : t ::: Type -> Navbar.mode t -> popupNav t -> xbody +(* Pretty prints a popup navigation as a piece of xml. *)