Mercurial > gui
comparison datebox.ur @ 4:377c11586999
Fully-functional Datebox
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Tue, 08 Feb 2011 16:52:29 -0500 |
parents | 8cab48efaff2 |
children | 4385bc6a0d2d |
comparison
equal
deleted
inserted
replaced
3:8cab48efaff2 | 4:377c11586999 |
---|---|
3 style this | 3 style this |
4 style next | 4 style next |
5 style weekday | 5 style weekday |
6 style curday | 6 style curday |
7 style otherday | 7 style otherday |
8 style selday | |
8 | 9 |
9 datatype month = Prev | This | Next | 10 datatype month = Prev | This | Next |
11 | |
12 type date = {Year : int, Month : int, Day : int} | |
10 | 13 |
11 type t = {Month : source {ThisMonth : int, Year : int, | 14 type t = {Month : source {ThisMonth : int, Year : int, |
12 ThisMonthLength : int, PrevMonthLength : int, | 15 ThisMonthLength : int, PrevMonthLength : int, |
13 MondayMonth : month, MondayDay : int, | 16 MondayMonth : month, MondayDay : int, |
14 PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, | 17 PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, |
15 Day : source int} | 18 Day : source date, |
19 Hide : source bool} | |
16 | 20 |
17 fun pad len n = | 21 fun pad len n = |
18 let | 22 let |
19 val s = show n | 23 val s = show n |
20 | 24 |
82 NextMonthName = timef "%b" (timeOfMonth next)} | 86 NextMonthName = timef "%b" (timeOfMonth next)} |
83 end | 87 end |
84 | 88 |
85 fun monthInfo this = return (monthInfo' this) | 89 fun monthInfo this = return (monthInfo' this) |
86 | 90 |
87 val create = | 91 fun create tm = |
88 tm <- now; | |
89 year <- return (readError (timef "%Y" tm)); | 92 year <- return (readError (timef "%Y" tm)); |
90 month <- return (readError (timef "%m" tm)); | 93 month <- return (readError (timef "%m" tm)); |
91 month <- source (monthInfo' {Month = month, Year = year}); | 94 minf <- source (monthInfo' {Month = month, Year = year}); |
92 day <- return (readError (timef "%d" tm)); | 95 day <- return (readError (timef "%d" tm)); |
93 day <- source day; | 96 day <- source {Year = year, Month = month, Day = day}; |
94 return {Month = month, Day = day} | 97 hide <- source True; |
95 | 98 return {Month = minf, Day = day, Hide = hide} |
96 fun render (t : t) = <xml> | 99 |
97 <dyn signal={minf <- signal t.Month; | 100 fun render' t = |
98 let | 101 minf <- signal t.Month; |
99 fun rows month day = | 102 let |
100 let | 103 fun rows year month day = |
101 fun row month day weekday = | 104 let |
102 if weekday >= 7 then | 105 fun row year month day weekday = |
103 <xml/> | 106 if weekday >= 7 then |
104 else | 107 <xml/> |
105 <xml> | 108 else |
106 <td class={case month of | 109 <xml> |
107 This => curday | 110 <dyn signal={let |
108 | _ => otherday}>{[day]}</td> | 111 val thisDate = {Year = year, |
109 {let | 112 Month = case month of |
110 val (month, day) = | 113 Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1 |
111 case month of | 114 | This => minf.ThisMonth |
112 Prev => if day = minf.PrevMonthLength then | 115 | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1, |
113 (This, 1) | 116 Day = day} |
114 else | 117 in |
115 (Prev, day+1) | 118 cday <- signal t.Day; |
116 | This => if day = minf.ThisMonthLength then | 119 return (if Record.equal thisDate cday then |
117 (Next, 1) | 120 <xml><td class={selday}>{[day]}</td></xml> |
118 else | 121 else case month of |
119 (This, day+1) | 122 This => <xml><td class={curday} |
120 | Next => (Next, day+1) | 123 onclick={set t.Day thisDate}>{[day]}</td></xml> |
121 in | 124 | _ => <xml><td class={otherday}>{[day]}</td></xml>) |
122 row month day (weekday+1) | 125 end}/> |
123 end} | 126 {let |
124 </xml> | 127 val (year, month, day) = |
128 case month of | |
129 Prev => if day = minf.PrevMonthLength then | |
130 (if minf.ThisMonth = 1 then year + 1 else year, This, 1) | |
131 else | |
132 (year, Prev, day+1) | |
133 | This => if day = minf.ThisMonthLength then | |
134 (if minf.ThisMonth = 12 then year + 1 else year, Next, 1) | |
135 else | |
136 (year, This, day+1) | |
137 | Next => (year, Next, day+1) | |
138 in | |
139 row year month day (weekday+1) | |
140 end} | |
141 </xml> | |
142 in | |
143 case month of | |
144 Next => <xml/> | |
145 | _ => | |
146 <xml> | |
147 <tr>{row year month day 0}</tr> | |
148 {let | |
149 val next = | |
150 case month of | |
151 Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength) | |
152 | This => | |
153 Some (if day + 7 > minf.ThisMonthLength then | |
154 (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength) | |
155 else | |
156 (year, This, day + 7)) | |
157 | Next => None | |
125 in | 158 in |
126 case month of | 159 case next of |
127 Next => <xml/> | 160 None => <xml/> |
128 | _ => | 161 | Some (year, month, day) => rows year month day |
129 <xml> | 162 end} |
130 <tr>{row month day 0}</tr> | 163 </xml> |
131 {let | 164 end |
132 val next = | 165 in |
133 case month of | 166 return <xml> |
134 Prev => Some (This, day + 7 - minf.PrevMonthLength) | 167 <table class={calendar}> |
135 | This => | 168 <tr> |
136 Some (if day + 7 > minf.ThisMonthLength then | 169 <th class={prev} colspan={2} |
137 (Next, day + 7 - minf.ThisMonthLength) | 170 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then |
138 else | 171 {Month = 12, Year = minf.Year - 1} |
139 (This, day + 7)) | 172 else |
140 | Next => None | 173 {Month = minf.ThisMonth - 1, Year = minf.Year})); |
141 in | 174 set t.Month minf}><< {[minf.PrevMonthName]}</th> |
142 case next of | 175 <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th> |
143 None => <xml/> | 176 <th class={next} colspan={2} |
144 | Some (month, day) => rows month day | 177 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then |
145 end} | 178 {Month = 1, Year = minf.Year + 1} |
146 </xml> | 179 else |
147 end | 180 {Month = minf.ThisMonth + 1, Year = minf.Year})); |
148 in | 181 set t.Month minf}>{[minf.NextMonthName]} >></th> |
149 return <xml> | 182 </tr> |
150 <table class={calendar}> | 183 <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> |
151 <tr> | 184 {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then |
152 <th class={prev} colspan={2} | 185 minf.Year - 1 |
153 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then | 186 else |
154 {Month = 12, Year = minf.Year - 1} | 187 minf.Year) minf.MondayMonth minf.MondayDay} |
155 else | 188 </table> |
156 {Month = minf.ThisMonth - 1, Year = minf.Year})); | 189 </xml> |
157 set t.Day 1; | 190 end |
158 set t.Month minf}><< {[minf.PrevMonthName]}</th> | 191 |
159 <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th> | 192 fun render t = <xml> |
160 <th class={next} colspan={2} | 193 <dyn signal={date <- signal t.Day; |
161 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then | 194 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/> |
162 {Month = 1, Year = minf.Year + 1} | 195 <dyn signal={hd <- signal t.Hide; |
163 else | 196 if hd then |
164 {Month = minf.ThisMonth + 1, Year = minf.Year})); | 197 return <xml><button value="Choose" onclick={set t.Hide False}/></xml> |
165 set t.Day 1; | 198 else |
166 set t.Month minf}>{[minf.NextMonthName]} >></th> | 199 main <- render' t; |
167 </tr> | 200 return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/> |
168 <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> | 201 </xml> |
169 {rows minf.MondayMonth minf.MondayDay} | 202 |
170 </table> | 203 fun value t = signal t.Day |
171 </xml> | |
172 end}/> | |
173 </xml> | |
174 | |
175 fun value t = | |
176 month <- signal t.Month; | |
177 day <- signal t.Day; | |
178 return {Year = month.Year, Month = month.ThisMonth, Day = day} |