Mercurial > gui
comparison datebox.ur @ 14:0827320b0f04
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}><< {[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) |