Mercurial > gui

comparison datebox.ur @ 12:bbdedfde154e

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