kkallio@7: functor Make(M : sig
kkallio@7:                  con linkPos :: {Unit}
kkallio@7:                  val linkFolder : folder linkPos
kkallio@7:                  con navbarPos :: {Unit}
kkallio@7:                  con msgPos :: {Unit}
kkallio@7:                  val msgFolder : folder msgPos
kkallio@7:                  con linkStyles :: {Type} = mapU (option css_class) linkPos
kkallio@7:                  con themePos :: {Unit}
kkallio@7:                  val linkStyles : $linkStyles
kkallio@7:                  val formatNav : $(mapU xbody navbarPos) -> $(mapU xbody linkPos) -> $(mapU xbody msgPos)
kkallio@7:                                  -> $(mapU xbody themePos)
kkallio@7:              end) = struct
kkallio@7: 
kkallio@7:     open Navbar
kkallio@7: 
kkallio@7:     con modeLs :: {Type} -> Type = fn r :: {Type} => $(map mode r)
kkallio@7:     con barLs :: {Type} -> Type = fn r :: {Type} => $(map navBar r)
kkallio@7: 
kkallio@7:     con linkLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option navItem) r)
kkallio@7:     con msgLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option xbody) r)
kkallio@7: 
adam@32:     con shape t = t -> $(mapU xbody M.navbarPos) 
kkallio@7: 
kkallio@7:     val shape_npos : shape $(mapU xbody M.navbarPos) = (fn x => x)
kkallio@7: 
kkallio@7:     con crush :: {Type} -> Type = fn r :: {Type} => $(map (fn _ => xbody) r) 
kkallio@7: 
kkallio@7:     con navigation :: {Type} -> Type = fn m :: {Type} => {Nav : barLs m,
kkallio@7:                                                           Link : linkLs M.linkPos,
kkallio@7:                                                           Msg : msgLs M.msgPos}
kkallio@7: 
kkallio@7:     fun mkNav [m ::: {Type}] (sh : shape (crush m)) (d : modeLs m) (n : barLs m) 
kkallio@7:               (l : linkLs M.linkPos) (msg : msgLs M.msgPos)  =
kkallio@7:         {Nav = n, Link = l, Msg = msg}
kkallio@7: 
kkallio@7:     fun barsToXml [m ::: {Type}] (fl : folder m) (ms : modeLs m) (ns : barLs m) = 
kkallio@7:         @@Top.fold [fn r :: {Type} => $(map mode r) -> $(map navBar r) -> $(map (fn _ => xbody) r)]
kkallio@7:           (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest]
kkallio@7:                            (acc : _ -> _ -> _) rm rn =>
kkallio@7:               {nm = @@navBarToXml [t] rm.nm rn.nm} ++ (acc (rm -- nm) (rn -- nm))) 
kkallio@7:           (fn _ _ => {}) [m] fl ms ns
kkallio@7: 
kkallio@7:     fun linksToXml (l : linkLs M.linkPos) =
kkallio@7:         let
kkallio@7:             fun render s ol =
kkallio@7:                 case ol of
kkallio@7:                     None => <xml/>
kkallio@7:                   | Some l => navItemToXml s l
kkallio@7: 
kkallio@7:         in
kkallio@7:             @@Top.fold [fn u :: {Unit} => $(mapU (option navItem) u) -> $(mapU (option css_class) u) -> $(mapU xbody u)]
kkallio@7:               (fn [nm :: Name] [t ::_] [rest :: {Unit}] [[nm] ~ rest]
kkallio@7:               (acc : _ -> _ -> _) r s => {nm = render s.nm r.nm} ++ (acc (r -- nm) (s -- nm)))
kkallio@7:               (fn _ _ => {}) [M.linkPos] M.linkFolder l M.linkStyles
kkallio@7:         end
kkallio@7: 
kkallio@7:     fun msgToXml (msg : msgLs M.msgPos) =
kkallio@7:         let 
kkallio@7:             fun render om =
kkallio@7:                 case om of
kkallio@7:                     None => <xml/>
kkallio@7:                   | Some m => m
kkallio@7:         in
kkallio@7:             @@Top.mp [fn u => (option xbody)] [fn u => xbody]
kkallio@7:               (fn [t :::_] => render) [M.msgPos] M.msgFolder msg
kkallio@7:         end
kkallio@7: 
kkallio@7:     fun toXml [m ::: {Type}] (fl : folder m) (sh : shape (crush m)) (d : modeLs m) {Nav = nav, Link = l, Msg = msg} =
kkallio@7:         M.formatNav (sh (@@barsToXml [m] fl d nav)) (linksToXml l) (msgToXml msg)
kkallio@7: 
kkallio@7: end