--- /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