Mercurial > gui

comparison datebox.ur @ 14:0827320b0f04

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Write calendarCtl in terms of a source with a listener.
author Karn Kallio <kkallio@eka>
date Fri, 05 Aug 2011 18:55:24 -0430
parents c016beb0ebac
children 8300d5f0dc19
comparison
equal deleted inserted replaced
13:c016beb0ebac 14:0827320b0f04
1 style calendar 1 type t = {Cal : Calendar.t,
2 style prev 2 Panel : TogglePanel.togglePanel Calendar.t}
3 style this
4 style next
5 style weekday
6 style curday
7 style otherday
8 style selday
9 3
10 datatype month = Prev | This | Next 4 type date = Calendar.date
5 val date_eq = Calendar.date_eq
6 val date_ord = Calendar.date_ord
7 val time = Calendar.time
8 val date = Calendar.date
11 9
12 type date = {Year : int, Month : int, Day : int} 10 val format = TogglePanel.defaultFormat
13 val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => 11 --#OpenCtl -- #CloseCtl
14 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2), 12 ++ {OpenCtl = fn behaviour => <xml><button value="Choose" onclick={behaviour}/></xml>,
15 Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => 13 CloseCtl = fn behaviour => <xml><button value="Hide" onclick={behaviour}/></xml>}
16 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
17
18 con cal = [Month = source {ThisMonth : int, Year : int,
19 ThisMonthLength : int, PrevMonthLength : int,
20 MondayMonth : month, MondayDay : int,
21 PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
22 Day = source date]
23
24 class givesDates t = t -> source date
25
26 type t = $(cal ++ [Hide = source bool])
27
28 fun givesDates_t x = x.Day
29
30 fun pad len n =
31 let
32 val s = show n
33
34 fun pad' len s =
35 if len <= 0 then
36 s
37 else
38 pad' (len-1) ("0" ^ s)
39 in
40 pad' (len - String.length s) s
41 end
42
43 fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
44 fun date tm =
45 let
46 val y = readError (timef "%Y" tm)
47 val m = readError (timef "%m" tm)
48 val d = readError (timef "%d" tm)
49 in
50 {Year = y, Month = m, Day = d}
51 end
52
53 fun monthLen m =
54 let
55 fun f n tm =
56 let
57 val next = addSeconds tm (60 * 60 * 24)
58 val nextMon = readError (timef "%m" next)
59 in
60 if nextMon = m.Month then
61 f (n+1) next
62 else
63 n
64 end
65 in
66 f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
67 end
68
69 fun weekdayToNum s =
70 case s of
71 "Mon" => 0
72 | "Tue" => 1
73 | "Wed" => 2
74 | "Thu" => 3
75 | "Fri" => 4
76 | "Sat" => 5
77 | "Sun" => 6
78 | _ => error <xml>Datebox: Bad weekday name</xml>
79
80 fun timeOfMonth my =
81 readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
82
83 fun monthInfo' this =
84 let
85 val prev = if this.Month = 1 then
86 {Month = 12, Year = this.Year - 1}
87 else
88 {Month = this.Month-1, Year = this.Year}
89 val prevLen = monthLen prev
90
91 val next = if this.Month = 12 then
92 {Month = 1, Year = this.Year + 1}
93 else
94 {Month = this.Month + 1, Year = this.Year}
95
96 val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
97 in
98 {ThisMonth = this.Month, Year = this.Year,
99 ThisMonthLength = monthLen this,
100 PrevMonthLength = prevLen,
101 MondayMonth = if firstDow = 0 then This else Prev,
102 MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
103 PrevMonthName = timef "%b" (timeOfMonth prev),
104 ThisMonthName = timef "%b" (timeOfMonth this),
105 NextMonthName = timef "%b" (timeOfMonth next)}
106 end
107
108 fun monthInfo this = return (monthInfo' this)
109 14
110 fun create tm = 15 fun create tm =
111 year <- return (readError (timef "%Y" tm)); 16 cal <- Calendar.create tm;
112 month <- return (readError (timef "%m" tm)); 17 panel <- TogglePanel.create format cal False;
113 minf <- source (monthInfo' {Month = month, Year = year});
114 day <- return (readError (timef "%d" tm));
115 day <- source {Year = year, Month = month, Day = day};
116 hide <- source True;
117 return {Month = minf, Day = day, Hide = hide}
118 18
119 fun render' action t = 19 return {Cal = cal,
120 minf <- signal t.Month; 20 Panel = panel}
121 let
122 fun rows year month day =
123 let
124 fun row year month day weekday =
125 if weekday >= 7 then
126 <xml/>
127 else
128 <xml>
129 <dyn signal={let
130 val thisDate = {Year = year,
131 Month = case month of
132 Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
133 | This => minf.ThisMonth
134 | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
135 Day = day}
136 in
137 cday <- signal t.Day;
138 return (if Record.equal thisDate cday then
139 <xml><td class={selday}>{[day]}</td></xml>
140 else case month of
141 This => <xml><td class={curday}
142 onclick={action thisDate; set t.Day thisDate}>{[day]}</td></xml>
143 | _ => <xml><td class={otherday}>{[day]}</td></xml>)
144 end}/>
145 {let
146 val (year, month, day) =
147 case month of
148 Prev => if day = minf.PrevMonthLength then
149 (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
150 else
151 (year, Prev, day+1)
152 | This => if day = minf.ThisMonthLength then
153 (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
154 else
155 (year, This, day+1)
156 | Next => (year, Next, day+1)
157 in
158 row year month day (weekday+1)
159 end}
160 </xml>
161 in
162 case month of
163 Next => <xml/>
164 | _ =>
165 <xml>
166 <tr>{row year month day 0}</tr>
167 {let
168 val next =
169 case month of
170 Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
171 | This =>
172 Some (if day + 7 > minf.ThisMonthLength then
173 (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
174 else
175 (year, This, day + 7))
176 | Next => None
177 in
178 case next of
179 None => <xml/>
180 | Some (year, month, day) => rows year month day
181 end}
182 </xml>
183 end
184 in
185 return <xml>
186 <table class={calendar}>
187 <tr>
188 <th class={prev} colspan={2}
189 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
190 {Month = 12, Year = minf.Year - 1}
191 else
192 {Month = minf.ThisMonth - 1, Year = minf.Year}));
193 set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
194 <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
195 <th class={next} colspan={2}
196 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
197 {Month = 1, Year = minf.Year + 1}
198 else
199 {Month = minf.ThisMonth + 1, Year = minf.Year}));
200 set t.Month minf}>{[minf.NextMonthName]} >></th>
201 </tr>
202 <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>
203 {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
204 minf.Year - 1
205 else
206 minf.Year) minf.MondayMonth minf.MondayDay}
207 </table>
208 </xml>
209 end
210 21
211 fun render t = <xml> 22 fun addListener f db =
212 <dyn signal={date <- signal t.Day; 23 Calendar.addListener f db.Cal
213 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
214 <dyn signal={hd <- signal t.Hide;
215 if hd then
216 return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
217 else
218 main <- render' (fn _ => return ()) (t -- #Hide);
219 return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
220 </xml>
221 24
222 type calendarCtl = $cal 25 fun set db day =
26 Calendar.set db.Cal day
223 27
224 fun givesDates_calendarCtl x = x.Day 28 fun value db = Calendar.value db.Cal
225 29
226 fun createCalendarCtl tm = 30 fun render db =
227 year <- return (readError (timef "%Y" tm));
228 month <- return (readError (timef "%m" tm));
229 minf <- source (monthInfo' {Month = month, Year = year});
230 day <- return (readError (timef "%d" tm));
231 day <- source {Year = year, Month = month, Day = day};
232 return {Month = minf, Day = day}
233
234 fun renderCalendarCtl action ctl =
235 <xml> 31 <xml>
236 <dyn signal={render' action ctl}/> 32 <dyn signal={date <- Calendar.value db.Cal;
33 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
34 {Gui.toXml db.Panel}
237 </xml> 35 </xml>
238
239 fun setCalendarCtl action ctl day =
240 minf <- rpc (monthInfo (day -- #Day));
241 action day;
242 set ctl.Month minf;
243 set ctl.Day day
244
245 fun value [t ::: Type] (gd : givesDates t) t = signal (gd t)