Mercurial > gui
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