Mercurial > gui

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