changeset 7:48a4180171b0

Shifted some more generic theme navigation code to the library. Also generalized formatting options a bit for popupNav.
author Karn Kallio <kkallio@eka>
date Fri, 06 May 2011 23:00:22 -0430
parents f17b869fbb71
children 90be8b8917d5
files examples/navtest.ur examples/navtest.urp examples/navtest.urs examples/popup.ur lib.urp navigation.ur navigation.urs popupNav.ur popupNav.urs
diffstat 9 files changed, 204 insertions(+), 4 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/navtest.ur	Fri May 06 23:00:22 2011 -0430
@@ -0,0 +1,45 @@
+open Navbar
+open Navigation
+
+val bar = navAdd (mkNavItem "Item 2" (bless "http://item2.com")) (navAdd (mkNavItem "Item 1" (bless "http://item1.org")) emptyNavBar)
+
+val link = mkNavItem "Special link" (bless "http://special.net")
+
+structure N = Make(struct
+                       con navbarPos = [Main]
+                       con msgPos = [Top]
+
+                       con themePos = [Main]
+
+                       val linkStyles = {Special = None}
+
+                       fun formatNav barPieces lnkPieces msgPieces =
+                           {Main = <xml>{msgPieces.Top}<h3>Here is a menu.</h3><ul>{barPieces.Main}<li>{lnkPieces.Special}</li></ul></xml>}
+                   end)
+
+open N
+
+val topMsg : xbody = <xml><div>A banner message</div></xml>
+
+val nav = mkNav {Main = bar} {Special = Some link} {Top = Some topMsg}
+
+val xml = toXml nav
+
+
+fun main () =
+    return <xml>
+      <head>
+        <title>Navbar Based Navigation.</title>
+      </head>
+      <body>
+        <h1>Example of using a Navigation.</h1>
+        <p>
+          This is a theme widget which manages a set
+          of links, messages and menus for site navigation.
+        </p>
+        <h2>Example of a navigation turned into a piece of xml.</h2>
+        <div>
+          {xml.Main}
+        </div>
+      </body>
+    </xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/navtest.urp	Fri May 06 23:00:22 2011 -0430
@@ -0,0 +1,7 @@
+path META=../../meta
+library ../
+rewrite url Navtest/*
+allow url http://*
+prefix http://localhost:8080/
+
+navtest
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/navtest.urs	Fri May 06 23:00:22 2011 -0430
@@ -0,0 +1,1 @@
+val main : unit -> transaction page
--- a/examples/popup.ur	Tue Apr 26 20:27:04 2011 -0430
+++ b/examples/popup.ur	Fri May 06 23:00:22 2011 -0430
@@ -8,7 +8,8 @@
 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>,
+val otherFormat = {FormatMenu = fn ctl menu => <xml><h3>A Custom {ctl} Format</h3>{menu}</xml>,
+                   WrapMenu = fn menu => <xml><div><ul>{menu}</ul></div></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>}
 
--- a/lib.urp	Tue Apr 26 20:27:04 2011 -0430
+++ b/lib.urp	Fri May 06 23:00:22 2011 -0430
@@ -9,4 +9,5 @@
 datebox
 navbar
 popupNav
+navigation
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/navigation.ur	Fri May 06 23:00:22 2011 -0430
@@ -0,0 +1,71 @@
+functor Make(M : sig
+                 con linkPos :: {Unit}
+                 val linkFolder : folder linkPos
+                 con navbarPos :: {Unit}
+                 con msgPos :: {Unit}
+                 val msgFolder : folder msgPos
+                 con linkStyles :: {Type} = mapU (option css_class) linkPos
+                 con themePos :: {Unit}
+                 val linkStyles : $linkStyles
+                 val formatNav : $(mapU xbody navbarPos) -> $(mapU xbody linkPos) -> $(mapU xbody msgPos)
+                                 -> $(mapU xbody themePos)
+             end) = struct
+
+    open Navbar
+
+    con modeLs :: {Type} -> Type = fn r :: {Type} => $(map mode r)
+    con barLs :: {Type} -> Type = fn r :: {Type} => $(map navBar r)
+
+    con linkLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option navItem) r)
+    con msgLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option xbody) r)
+
+    class shape t = t -> $(mapU xbody M.navbarPos) 
+
+    val shape_npos : shape $(mapU xbody M.navbarPos) = (fn x => x)
+
+    con crush :: {Type} -> Type = fn r :: {Type} => $(map (fn _ => xbody) r) 
+
+    con navigation :: {Type} -> Type = fn m :: {Type} => {Nav : barLs m,
+                                                          Link : linkLs M.linkPos,
+                                                          Msg : msgLs M.msgPos}
+
+    fun mkNav [m ::: {Type}] (sh : shape (crush m)) (d : modeLs m) (n : barLs m) 
+              (l : linkLs M.linkPos) (msg : msgLs M.msgPos)  =
+        {Nav = n, Link = l, Msg = msg}
+
+    fun barsToXml [m ::: {Type}] (fl : folder m) (ms : modeLs m) (ns : barLs m) = 
+        @@Top.fold [fn r :: {Type} => $(map mode r) -> $(map navBar r) -> $(map (fn _ => xbody) r)]
+          (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest]
+                           (acc : _ -> _ -> _) rm rn =>
+              {nm = @@navBarToXml [t] rm.nm rn.nm} ++ (acc (rm -- nm) (rn -- nm))) 
+          (fn _ _ => {}) [m] fl ms ns
+
+    fun linksToXml (l : linkLs M.linkPos) =
+        let
+            fun render s ol =
+                case ol of
+                    None => <xml/>
+                  | Some l => navItemToXml s l
+
+        in
+            @@Top.fold [fn u :: {Unit} => $(mapU (option navItem) u) -> $(mapU (option css_class) u) -> $(mapU xbody u)]
+              (fn [nm :: Name] [t ::_] [rest :: {Unit}] [[nm] ~ rest]
+              (acc : _ -> _ -> _) r s => {nm = render s.nm r.nm} ++ (acc (r -- nm) (s -- nm)))
+              (fn _ _ => {}) [M.linkPos] M.linkFolder l M.linkStyles
+        end
+
+    fun msgToXml (msg : msgLs M.msgPos) =
+        let 
+            fun render om =
+                case om of
+                    None => <xml/>
+                  | Some m => m
+        in
+            @@Top.mp [fn u => (option xbody)] [fn u => xbody]
+              (fn [t :::_] => render) [M.msgPos] M.msgFolder msg
+        end
+
+    fun toXml [m ::: {Type}] (fl : folder m) (sh : shape (crush m)) (d : modeLs m) {Nav = nav, Link = l, Msg = msg} =
+        M.formatNav (sh (@@barsToXml [m] fl d nav)) (linksToXml l) (msgToXml msg)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/navigation.urs	Fri May 06 23:00:22 2011 -0430
@@ -0,0 +1,66 @@
+(* A navigation is a collection of navigation bars (menus) made of links of
+ * which up to one may be marked as active, optional isolated links not part of
+ * menu bars and also optional message or status zones containing xml.  The
+ * programmer can provide a way to format these elements into a collection of
+ * pieces of xml which can then be inserted into themes. *)
+
+functor Make(M : sig
+                 con linkPos :: {Unit}
+                 (* The collection of isolated links.  Should be inferred. *)
+
+                 val linkFolder : folder linkPos
+                 (* Implementation detail; should be inferred. *) 
+
+                 con navbarPos :: {Unit}
+                 (* The collection of navbars. *)
+ 
+                 con msgPos :: {Unit}
+                 (* The collection of optional status or message xml pieces. *)
+
+                 val msgFolder : folder msgPos
+                 (* Implementation detail; should be inferred. *)
+
+                 con linkStyles :: {Type} = mapU (option css_class) linkPos
+                 (* The collection of isolated links, with an optional CSS class
+                  * which will be applied to that link. *) 
+
+                 con themePos :: {Unit}
+                 (* The positions in the theme to generate xml for. *)
+
+                 val linkStyles : $linkStyles
+                 (* The input optional link positions and styles. *)
+
+                 val formatNav : $(mapU xbody navbarPos) -> $(mapU xbody linkPos) -> $(mapU xbody msgPos)
+                                 -> $(mapU xbody themePos)
+                 (* The way to format the collections of navbars, links and message
+                  * zones into pieces of xml for the theme positions. *)
+
+             end) : sig
+
+    con modeLs :: {Type} -> Type = fn r :: {Type} => $(map Navbar.mode r)
+    con barLs :: {Type} -> Type = fn r :: {Type} => $(map Navbar.navBar r)
+
+    con linkLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option Navbar.navItem) r)
+    con msgLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option xbody) r)
+
+    class shape
+
+    val shape_npos : shape $(mapU xbody M.navbarPos)
+
+    con crush :: {Type} -> Type = fn r :: {Type} => $(map (fn _ => xbody) r) 
+
+    con navigation :: {Type} -> Type = fn m :: {Type} => {Nav : barLs m,
+                                                          Link : linkLs M.linkPos,
+                                                          Msg : msgLs M.msgPos}
+    (* Represents a complete navigation ensemble. *)                                                     
+
+    val mkNav : m ::: {Type} -> shape (crush m) -> modeLs m -> barLs m
+                -> linkLs M.linkPos -> msgLs M.msgPos
+                -> navigation m
+    (* Builds a navigation from input elements of navbars, isolated links and messages. *) 
+
+    val toXml : m ::: {Type} -> folder m -> shape (crush m) -> modeLs m 
+                -> navigation m -> $(mapU xbody M.themePos)
+    (* Renders a navigation to xml pieces suitable for inclusion in a theme. *)
+
+end
--- a/popupNav.ur	Tue Apr 26 20:27:04 2011 -0430
+++ b/popupNav.ur	Fri May 06 23:00:22 2011 -0430
@@ -1,10 +1,12 @@
 datatype menuState = Open | Closed
 
 type formatCtl = {FormatMenu : xbody -> xbody -> xbody,
+                  WrapMenu : xbody -> xbody,
                   OpenCtl : transaction unit -> xbody,
                   CloseCtl : transaction unit -> xbody}
 
-val defaultFormat = {FormatMenu = fn ctl menu => <xml>{ctl}<ul>{menu}</ul></xml>,
+val defaultFormat = {FormatMenu = fn ctl menu => <xml>{ctl}{menu}</xml>,
+                     WrapMenu = fn menu => <xml><ul>{menu}</ul></xml>,
                      OpenCtl = fn behaviour => <xml><button value="Open" onclick={behaviour}/></xml>,
                      CloseCtl = fn behaviour => <xml><button value="Close" onclick={behaviour}/></xml>}
 
@@ -36,7 +38,7 @@
           <dyn signal={c <- signal popup.MenuState;
                        return
                            (case c of
-                                Open => <xml>{navBarToXml popup.NavBar}</xml>
+                                Open => <xml>{popup.FormatCtl.WrapMenu (navBarToXml popup.NavBar)}</xml>
                               | Closed => <xml/>)
                       }/>
         </xml>
--- a/popupNav.urs	Tue Apr 26 20:27:04 2011 -0430
+++ b/popupNav.urs	Fri May 06 23:00:22 2011 -0430
@@ -9,7 +9,13 @@
                    * 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>. *)
+                   * will be placed as a chain of <li><a> ....</a></li> wrapped
+                   * as given below.  The menu part appears and disappears according
+                   * to the use of the controls. *)
+
+                   WrapMenu : xbody -> xbody,
+                   (* This allows for the wrapping of menu <li> ... </li> with some
+                    * chrome that will appear and disappear. *)
 
                   OpenCtl : transaction unit -> xbody,
                   (* This should accept the transaction representing the opening of