# HG changeset patch # User Karn Kallio # Date 1303865824 16200 # Node ID f17b869fbb7179acd17fd2fdb4908dfd56a39cd4 # Parent 4385bc6a0d2d05963991ff074ee7f6ccd1919eaf Shifting some generic theme navigation menu code to the library. diff -r 4385bc6a0d2d -r f17b869fbb71 examples/popup.ur --- /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 =>

A Custom {ctl} Format

{menu}, + OpenCtl = fn behaviour => View, + CloseCtl = fn behaviour => Hide} + + +fun main () = + + defaultFormatPopUp <- create defaultFormat testNav'; + otherFormatPopUp <- create otherFormat testNav'; + + return + + Navbar Based Popup Navigation. + + +

Example of using Navbar to build a widget.

+ This is a widget which generates a popup list + of links. +

Example of the default format.

+ {render defaultFormatPopUp} +

Example of another format.

+ {render otherFormatPopUp} +

+ + diff -r 4385bc6a0d2d -r f17b869fbb71 examples/popup.urp --- /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 diff -r 4385bc6a0d2d -r f17b869fbb71 examples/popup.urs --- /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 diff -r 4385bc6a0d2d -r f17b869fbb71 lib.urp --- 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 + diff -r 4385bc6a0d2d -r f17b869fbb71 navbar.ur --- /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 + [] => + | x :: [] => {f x True} + | x :: ls => {f x False}{mapXLast' ls} + in + mapXLast' ls + end + +fun navItemToXml css (NavItem (text, url)) = + case css of + None => {[text]} + | Some cl => {[text]} + +fun navBarToXml' (NavBar (before, after)) = + let + fun navListToXml checkForLast = + mapXLast (fn navItem lst => + let + val linkXml = navItemToXml None navItem + in + if checkForLast && lst then +

{linkXml}

+ else +

{linkXml}

+ end) + in + case after of + [] => {navListToXml True before} + | act :: tl => + + {navListToXml False before} + {case tl of + [] =>

{navItemToXml (Some active) act}

+ | _ => + +

{navItemToXml (Some active) act}

+ {navListToXml True tl} + } + + 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 :: []) diff -r 4385bc6a0d2d -r f17b869fbb71 navbar.urs --- /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 ... xml. *) + +val navBarToXml : t ::: Type -> mode t -> navBar t -> xbody +(* Pretty print the navigation menu as a piece of xml made of + * a chain

...

repeated. *) + +style active +style last +(* CSS classes to mark the active and last menu item. *) diff -r 4385bc6a0d2d -r f17b869fbb71 popupNav.ur --- /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 => {ctl}

{menu}, + OpenCtl = fn behaviour =>