Mercurial > gui
comparison datebox.ur @ 12:bbdedfde154e
Add a calendar control.
author | Karn Kallio <kkallio@eka> |
---|---|
date | Thu, 28 Jul 2011 10:24:34 -0430 |
parents | 4385bc6a0d2d |
children | c016beb0ebac |
comparison
equal
deleted
inserted
replaced
11:ccd0a169e827 | 12:bbdedfde154e |
---|---|
13 val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => | 13 val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => |
14 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2), | 14 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2), |
15 Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => | 15 Le = 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)} | 16 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)} |
17 | 17 |
18 type t = {Month : source {ThisMonth : int, Year : int, | 18 con cal = [Month = source {ThisMonth : int, Year : int, |
19 ThisMonthLength : int, PrevMonthLength : int, | 19 ThisMonthLength : int, PrevMonthLength : int, |
20 MondayMonth : month, MondayDay : int, | 20 MondayMonth : month, MondayDay : int, |
21 PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, | 21 PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, |
22 Day : source date, | 22 Day = source date] |
23 Hide : source bool} | 23 |
24 class givesDates t = t -> source date | |
25 | |
26 type t = $(cal ++ [Hide = source bool]) | |
27 | |
28 fun givesDates_t x = x.Day | |
24 | 29 |
25 fun pad len n = | 30 fun pad len n = |
26 let | 31 let |
27 val s = show n | 32 val s = show n |
28 | 33 |
34 in | 39 in |
35 pad' (len - String.length s) s | 40 pad' (len - String.length s) s |
36 end | 41 end |
37 | 42 |
38 fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00") | 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 | |
39 | 52 |
40 fun monthLen m = | 53 fun monthLen m = |
41 let | 54 let |
42 fun f n tm = | 55 fun f n tm = |
43 let | 56 let |
101 day <- return (readError (timef "%d" tm)); | 114 day <- return (readError (timef "%d" tm)); |
102 day <- source {Year = year, Month = month, Day = day}; | 115 day <- source {Year = year, Month = month, Day = day}; |
103 hide <- source True; | 116 hide <- source True; |
104 return {Month = minf, Day = day, Hide = hide} | 117 return {Month = minf, Day = day, Hide = hide} |
105 | 118 |
106 fun render' t = | 119 fun render' action t = |
107 minf <- signal t.Month; | 120 minf <- signal t.Month; |
108 let | 121 let |
109 fun rows year month day = | 122 fun rows year month day = |
110 let | 123 let |
111 fun row year month day weekday = | 124 fun row year month day weekday = |
124 cday <- signal t.Day; | 137 cday <- signal t.Day; |
125 return (if Record.equal thisDate cday then | 138 return (if Record.equal thisDate cday then |
126 <xml><td class={selday}>{[day]}</td></xml> | 139 <xml><td class={selday}>{[day]}</td></xml> |
127 else case month of | 140 else case month of |
128 This => <xml><td class={curday} | 141 This => <xml><td class={curday} |
129 onclick={set t.Day thisDate}>{[day]}</td></xml> | 142 onclick={action thisDate; set t.Day thisDate}>{[day]}</td></xml> |
130 | _ => <xml><td class={otherday}>{[day]}</td></xml>) | 143 | _ => <xml><td class={otherday}>{[day]}</td></xml>) |
131 end}/> | 144 end}/> |
132 {let | 145 {let |
133 val (year, month, day) = | 146 val (year, month, day) = |
134 case month of | 147 case month of |
200 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/> | 213 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/> |
201 <dyn signal={hd <- signal t.Hide; | 214 <dyn signal={hd <- signal t.Hide; |
202 if hd then | 215 if hd then |
203 return <xml><button value="Choose" onclick={set t.Hide False}/></xml> | 216 return <xml><button value="Choose" onclick={set t.Hide False}/></xml> |
204 else | 217 else |
205 main <- render' t; | 218 main <- render' (fn _ => return ()) (t -- #Hide); |
206 return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/> | 219 return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/> |
207 </xml> | 220 </xml> |
208 | 221 |
209 fun value t = signal t.Day | 222 type calendarCtl = $cal |
223 | |
224 fun givesDates_calendarCtl x = x.Day | |
225 | |
226 fun createCalendarCtl tm = | |
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> | |
236 <dyn signal={render' action ctl}/> | |
237 </xml> | |
238 | |
239 fun setCalendarCtl action ctl day = | |
240 action day; | |
241 set ctl.Day day | |
242 | |
243 fun value [t ::: Type] (gd : givesDates t) t = signal (gd t) |