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. *)