Mercurial > gui

comparison navbar.ur @ 6:f17b869fbb71

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Shifting some generic theme navigation menu code to the library.
author Karn Kallio <kkallio@eka>
date Tue, 26 Apr 2011 20:27:04 -0430
parents
children d314d2ec3300
comparison
equal deleted inserted replaced
5:4385bc6a0d2d 6:f17b869fbb71
1 style active
2 style last
3
4 datatype navItem = NavItem of string * url
5
6 datatype navBar m = NavBar of (list navItem) * (list navItem)
7 (* First list is items before the active item, second list is items at and after the active one.
8 * If the second list is non-empty its head is the active item. Parameter mode is to avoid
9 * double reverses coming from calling printingNavBar. *)
10
11 type build = unit
12 type print = unit
13
14 class mode t = navBar t -> xbody
15
16 (* The case of special treatment for the last one seems common in themes. *)
17 fun mapXLast [a ::: Type] [ctx ::: {Unit}] (f : a -> bool -> xml ctx [] []) (ls : list a) : (xml ctx [] []) =
18 let
19 fun mapXLast' ls =
20 case ls of
21 [] => <xml/>
22 | x :: [] => <xml>{f x True}</xml>
23 | x :: ls => <xml>{f x False}{mapXLast' ls}</xml>
24 in
25 mapXLast' ls
26 end
27
28 fun navItemToXml css (NavItem (text, url)) =
29 case css of
30 None => <xml><a href={url} title={text}>{[text]}</a></xml>
31 | Some cl => <xml><a class={cl} href={url} title={text}>{[text]}</a></xml>
32
33 fun navBarToXml' (NavBar (before, after)) =
34 let
35 fun navListToXml checkForLast =
36 mapXLast (fn navItem lst =>
37 let
38 val linkXml = navItemToXml None navItem
39 in
40 if checkForLast && lst then
41 <xml><li class={last}>{linkXml}</li></xml>
42 else
43 <xml><li>{linkXml}</li></xml>
44 end)
45 in
46 case after of
47 [] => <xml>{navListToXml True before}</xml>
48 | act :: tl =>
49 <xml>
50 {navListToXml False before}
51 {case tl of
52 [] => <xml><li class={last}>{navItemToXml (Some active) act}</li></xml>
53 | _ =>
54 <xml>
55 <li>{navItemToXml (Some active) act}</li>
56 {navListToXml True tl}
57 </xml>}
58 </xml>
59 end
60
61 fun printingNavBar (NavBar (before, after)) =
62 NavBar (List.rev before, List.rev after)
63
64 fun navBarToXml [t ::: Type] (m : mode t) = m
65
66 fun navToXml_build (n : navBar build) : xbody =
67 navBarToXml' (printingNavBar n)
68
69 fun navToXml_print (n: navBar print) : xbody =
70 navBarToXml' n
71
72 val emptyNavBar = NavBar ([], [])
73
74 fun mkNavItem text url =
75 NavItem (text, url)
76
77 fun navAdd navItem navBar =
78 case navBar of
79 NavBar (before, []) => NavBar (navItem :: before, [])
80 | NavBar (before, after) => NavBar (before, navItem :: after)
81
82 fun navAddActive navItem navBar =
83 case navBar of
84 NavBar (before, []) => NavBar (before, navItem :: [])
85 | NavBar (before, after) => NavBar (List.append after before, navItem :: [])