Mercurial > gui

comparison datebox.ur @ 4:377c11586999

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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}>&lt;&lt; {[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}>&lt;&lt; {[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}