# HG changeset patch # User Karn Kallio # Date 1304739022 16200 # Node ID 48a4180171b090a346b64868dc6787c6e54773f2 # Parent f17b869fbb7179acd17fd2fdb4908dfd56a39cd4 Shifted some more generic theme navigation code to the library. Also generalized formatting options a bit for popupNav. diff -r f17b869fbb71 -r 48a4180171b0 examples/navtest.ur --- /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 = {msgPieces.Top}

Here is a menu.

{lnkPieces.Special}

} + end) + +open N + +val topMsg : xbody =

A banner message

+ +val nav = mkNav {Main = bar} {Special = Some link} {Top = Some topMsg} + +val xml = toXml nav + + +fun main () = + return + + Navbar Based Navigation. + + +

Example of using a Navigation.

+ This is a theme widget which manages a set + of links, messages and menus for site navigation. +

Example of a navigation turned into a piece of xml.

+ {xml.Main} +

+ + diff -r f17b869fbb71 -r 48a4180171b0 examples/navtest.urp --- /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 diff -r f17b869fbb71 -r 48a4180171b0 examples/navtest.urs --- /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 diff -r f17b869fbb71 -r 48a4180171b0 examples/popup.ur --- 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 =>

A Custom {ctl} Format

{menu}, +val otherFormat = {FormatMenu = fn ctl menu =>

A Custom {ctl} Format

{menu}, + WrapMenu = fn menu =>

{menu}

, OpenCtl = fn behaviour => View, CloseCtl = fn behaviour => Hide} diff -r f17b869fbb71 -r 48a4180171b0 lib.urp --- 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 diff -r f17b869fbb71 -r 48a4180171b0 navigation.ur --- /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 => + | 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 => + | 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 diff -r f17b869fbb71 -r 48a4180171b0 navigation.urs --- /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 diff -r f17b869fbb71 -r 48a4180171b0 popupNav.ur --- 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 => {ctl}

{menu}, +val defaultFormat = {FormatMenu = fn ctl menu => {ctl}{menu}, + WrapMenu = fn menu =>

{menu}, OpenCtl = fn behaviour =>