Mercurial > gui

comparison datebox.ur @ 2:33c83ae7c9af

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of datebox: calendarizing current month correctly
author Adam Chlipala <adam@chlipala.net>
date Tue, 08 Feb 2011 15:51:42 -0500
parents
children 8cab48efaff2
comparison
equal deleted inserted replaced
1:4d8165e8f89a 2:33c83ae7c9af
1 style calendar
2 style prev
3 style this
4 style next
5 style weekday
6 style curday
7 style otherday
8
9 datatype month = Prev | This | Next
10
11 type t = {Month : source {ThisMonth : int, Year : int,
12 ThisMonthLength : int, PrevMonthLength : int,
13 MondayMonth : month, MondayDay : int,
14 PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
15 Day : source int}
16
17 fun pad len n =
18 let
19 val s = show n
20
21 fun pad' len s =
22 if len <= 0 then
23 s
24 else
25 pad' (len-1) ("0" ^ s)
26 in
27 pad' (len - String.length s) s
28 end
29
30 fun monthLen m =
31 let
32 fun f n tm =
33 let
34 val next = addSeconds tm (60 * 60 * 24)
35 val nextMon = readError (timef "%m" next)
36 in
37 if nextMon = m.Month then
38 f (n+1) next
39 else
40 n
41 end
42 in
43 f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
44 end
45
46 fun weekdayToNum s =
47 case s of
48 "Mon" => 0
49 | "Tue" => 1
50 | "Wed" => 2
51 | "Thu" => 3
52 | "Fri" => 4
53 | "Sat" => 5
54 | "Sun" => 6
55 | _ => error <xml>Datebox: Bad weekday name</xml>
56
57 fun timeOfMonth my =
58 readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
59
60 fun monthInfo this =
61 let
62 val prev = if this.Month = 1 then
63 {Month = 12, Year = this.Year - 1}
64 else
65 {Month = this.Month-1, Year = this.Year}
66 val prevLen = monthLen prev
67
68 val next = if this.Month = 12 then
69 {Month = 1, Year = this.Year + 1}
70 else
71 {Month = this.Month + 1, Year = this.Year}
72
73 val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
74 in
75 {ThisMonth = this.Month, Year = this.Year,
76 ThisMonthLength = monthLen this,
77 PrevMonthLength = prevLen,
78 MondayMonth = if firstDow = 0 then This else Prev,
79 MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
80 PrevMonthName = timef "%b" (timeOfMonth prev),
81 ThisMonthName = timef "%b" (timeOfMonth this),
82 NextMonthName = timef "%b" (timeOfMonth next)}
83 end
84
85 val create =
86 tm <- now;
87 year <- return (readError (timef "%Y" tm));
88 month <- return (readError (timef "%m" tm));
89 month <- source (monthInfo {Month = month, Year = year});
90 day <- return (readError (timef "%d" tm));
91 day <- source day;
92 return {Month = month, Day = day}
93
94 fun render (t : t) = <xml>
95 <dyn signal={minf <- signal t.Month;
96 let
97 fun rows month day =
98 let
99 fun row month day weekday =
100 if weekday >= 7 then
101 <xml/>
102 else
103 <xml>
104 <td class={case month of
105 This => curday
106 | _ => otherday}>{[day]}</td>
107 {let
108 val (month, day) =
109 case month of
110 Prev => if day = minf.PrevMonthLength then
111 (This, 1)
112 else
113 (Prev, day+1)
114 | This => if day = minf.ThisMonthLength then
115 (Next, 1)
116 else
117 (This, day+1)
118 | Next => (Next, day+1)
119 in
120 row month day (weekday+1)
121 end}
122 </xml>
123 in
124 case month of
125 Next => <xml/>
126 | _ =>
127 <xml>
128 <tr>{row month day 0}</tr>
129 {let
130 val next =
131 case month of
132 Prev => Some (This, day + 7 - minf.PrevMonthLength)
133 | This =>
134 Some (if day + 7 > minf.ThisMonthLength then
135 (Next, day + 7 - minf.ThisMonthLength)
136 else
137 (This, day + 7))
138 | Next => None
139 in
140 case next of
141 None => <xml/>
142 | Some (month, day) => rows month day
143 end}
144 </xml>
145 end
146 in
147 return <xml>
148 <table class={calendar}>
149 <tr>
150 <th class={prev} colspan={2}>&lt;&lt; {[minf.PrevMonthName]}</th>
151 <th class={this} colspan={3}>{[minf.ThisMonthName]}</th>
152 <th class={next} colspan={2}>{[minf.NextMonthName]} >></th>
153 </tr>
154 <tr class={weekday}> <th>M</th> <th>Tu</th> <th>W</th> <th>Th</th> <th>F</th> <th>Sa</th> <th>Su</th> </tr>
155 {rows minf.MondayMonth minf.MondayDay}
156 </table>
157 </xml>
158 end}/>
159 </xml>
160
161 fun value t =
162 month <- signal t.Month;
163 day <- signal t.Day;
164 return (readError (show month.Year ^ "-" ^ pad 2 month.ThisMonth ^ "-" ^ pad 2 day ^ " 00:00:00"))