Mercurial > gui

comparison navigation.ur @ 7:48a4180171b0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
children d32fb0f7b137
comparison
equal deleted inserted replaced
6:f17b869fbb71 7:48a4180171b0
1 functor Make(M : sig
2 con linkPos :: {Unit}
3 val linkFolder : folder linkPos
4 con navbarPos :: {Unit}
5 con msgPos :: {Unit}
6 val msgFolder : folder msgPos
7 con linkStyles :: {Type} = mapU (option css_class) linkPos
8 con themePos :: {Unit}
9 val linkStyles : $linkStyles
10 val formatNav : $(mapU xbody navbarPos) -> $(mapU xbody linkPos) -> $(mapU xbody msgPos)
11 -> $(mapU xbody themePos)
12 end) = struct
13
14 open Navbar
15
16 con modeLs :: {Type} -> Type = fn r :: {Type} => $(map mode r)
17 con barLs :: {Type} -> Type = fn r :: {Type} => $(map navBar r)
18
19 con linkLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option navItem) r)
20 con msgLs :: {Unit} -> Type = fn r :: {Unit} => $(mapU (option xbody) r)
21
22 class shape t = t -> $(mapU xbody M.navbarPos)
23
24 val shape_npos : shape $(mapU xbody M.navbarPos) = (fn x => x)
25
26 con crush :: {Type} -> Type = fn r :: {Type} => $(map (fn _ => xbody) r)
27
28 con navigation :: {Type} -> Type = fn m :: {Type} => {Nav : barLs m,
29 Link : linkLs M.linkPos,
30 Msg : msgLs M.msgPos}
31
32 fun mkNav [m ::: {Type}] (sh : shape (crush m)) (d : modeLs m) (n : barLs m)
33 (l : linkLs M.linkPos) (msg : msgLs M.msgPos) =
34 {Nav = n, Link = l, Msg = msg}
35
36 fun barsToXml [m ::: {Type}] (fl : folder m) (ms : modeLs m) (ns : barLs m) =
37 @@Top.fold [fn r :: {Type} => $(map mode r) -> $(map navBar r) -> $(map (fn _ => xbody) r)]
38 (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest]
39 (acc : _ -> _ -> _) rm rn =>
40 {nm = @@navBarToXml [t] rm.nm rn.nm} ++ (acc (rm -- nm) (rn -- nm)))
41 (fn _ _ => {}) [m] fl ms ns
42
43 fun linksToXml (l : linkLs M.linkPos) =
44 let
45 fun render s ol =
46 case ol of
47 None => <xml/>
48 | Some l => navItemToXml s l
49
50 in
51 @@Top.fold [fn u :: {Unit} => $(mapU (option navItem) u) -> $(mapU (option css_class) u) -> $(mapU xbody u)]
52 (fn [nm :: Name] [t ::_] [rest :: {Unit}] [[nm] ~ rest]
53 (acc : _ -> _ -> _) r s => {nm = render s.nm r.nm} ++ (acc (r -- nm) (s -- nm)))
54 (fn _ _ => {}) [M.linkPos] M.linkFolder l M.linkStyles
55 end
56
57 fun msgToXml (msg : msgLs M.msgPos) =
58 let
59 fun render om =
60 case om of
61 None => <xml/>
62 | Some m => m
63 in
64 @@Top.mp [fn u => (option xbody)] [fn u => xbody]
65 (fn [t :::_] => render) [M.msgPos] M.msgFolder msg
66 end
67
68 fun toXml [m ::: {Type}] (fl : folder m) (sh : shape (crush m)) (d : modeLs m) {Nav = nav, Link = l, Msg = msg} =
69 M.formatNav (sh (@@barsToXml [m] fl d nav)) (linksToXml l) (msgToXml msg)
70
71 end