Mercurial > gui

annotate datebox.ur @ 13:c016beb0ebac

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Repair calendarCtl : adjust monthinfo when set.
author Karn Kallio <kkallio@eka>
date Thu, 28 Jul 2011 11:51:10 -0430
parents bbdedfde154e
children 0827320b0f04
rev   line source
adam@2 1 style calendar
adam@2 2 style prev
adam@2 3 style this
adam@2 4 style next
adam@2 5 style weekday
adam@2 6 style curday
adam@2 7 style otherday
adam@4 8 style selday
adam@2 9
adam@2 10 datatype month = Prev | This | Next
adam@2 11
adam@4 12 type date = {Year : int, Month : int, Day : int}
adam@5 13 val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
adam@5 14 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2),
adam@5 15 Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
adam@5 16 y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
adam@4 17
kkallio@12 18 con cal = [Month = source {ThisMonth : int, Year : int,
kkallio@12 19 ThisMonthLength : int, PrevMonthLength : int,
kkallio@12 20 MondayMonth : month, MondayDay : int,
kkallio@12 21 PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
kkallio@12 22 Day = source date]
kkallio@12 23
kkallio@12 24 class givesDates t = t -> source date
kkallio@12 25
kkallio@12 26 type t = $(cal ++ [Hide = source bool])
kkallio@12 27
kkallio@12 28 fun givesDates_t x = x.Day
adam@2 29
adam@2 30 fun pad len n =
adam@2 31 let
adam@2 32 val s = show n
adam@2 33
adam@2 34 fun pad' len s =
adam@2 35 if len <= 0 then
adam@2 36 s
adam@2 37 else
adam@2 38 pad' (len-1) ("0" ^ s)
adam@2 39 in
adam@2 40 pad' (len - String.length s) s
adam@2 41 end
adam@2 42
adam@5 43 fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
kkallio@12 44 fun date tm =
kkallio@12 45 let
kkallio@12 46 val y = readError (timef "%Y" tm)
kkallio@12 47 val m = readError (timef "%m" tm)
kkallio@12 48 val d = readError (timef "%d" tm)
kkallio@12 49 in
kkallio@12 50 {Year = y, Month = m, Day = d}
kkallio@12 51 end
adam@5 52
adam@2 53 fun monthLen m =
adam@2 54 let
adam@2 55 fun f n tm =
adam@2 56 let
adam@2 57 val next = addSeconds tm (60 * 60 * 24)
adam@2 58 val nextMon = readError (timef "%m" next)
adam@2 59 in
adam@2 60 if nextMon = m.Month then
adam@2 61 f (n+1) next
adam@2 62 else
adam@2 63 n
adam@2 64 end
adam@2 65 in
adam@2 66 f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
adam@2 67 end
adam@2 68
adam@2 69 fun weekdayToNum s =
adam@2 70 case s of
adam@2 71 "Mon" => 0
adam@2 72 | "Tue" => 1
adam@2 73 | "Wed" => 2
adam@2 74 | "Thu" => 3
adam@2 75 | "Fri" => 4
adam@2 76 | "Sat" => 5
adam@2 77 | "Sun" => 6
adam@2 78 | _ => error <xml>Datebox: Bad weekday name</xml>
adam@2 79
adam@2 80 fun timeOfMonth my =
adam@2 81 readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
adam@2 82
adam@3 83 fun monthInfo' this =
adam@2 84 let
adam@2 85 val prev = if this.Month = 1 then
adam@2 86 {Month = 12, Year = this.Year - 1}
adam@2 87 else
adam@2 88 {Month = this.Month-1, Year = this.Year}
adam@2 89 val prevLen = monthLen prev
adam@2 90
adam@2 91 val next = if this.Month = 12 then
adam@2 92 {Month = 1, Year = this.Year + 1}
adam@2 93 else
adam@2 94 {Month = this.Month + 1, Year = this.Year}
adam@2 95
adam@2 96 val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
adam@2 97 in
adam@2 98 {ThisMonth = this.Month, Year = this.Year,
adam@2 99 ThisMonthLength = monthLen this,
adam@2 100 PrevMonthLength = prevLen,
adam@2 101 MondayMonth = if firstDow = 0 then This else Prev,
adam@2 102 MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
adam@2 103 PrevMonthName = timef "%b" (timeOfMonth prev),
adam@2 104 ThisMonthName = timef "%b" (timeOfMonth this),
adam@2 105 NextMonthName = timef "%b" (timeOfMonth next)}
adam@2 106 end
adam@2 107
adam@3 108 fun monthInfo this = return (monthInfo' this)
adam@3 109
adam@4 110 fun create tm =
adam@2 111 year <- return (readError (timef "%Y" tm));
adam@2 112 month <- return (readError (timef "%m" tm));
adam@4 113 minf <- source (monthInfo' {Month = month, Year = year});
adam@2 114 day <- return (readError (timef "%d" tm));
adam@4 115 day <- source {Year = year, Month = month, Day = day};
adam@4 116 hide <- source True;
adam@4 117 return {Month = minf, Day = day, Hide = hide}
adam@2 118
kkallio@12 119 fun render' action t =
adam@4 120 minf <- signal t.Month;
adam@4 121 let
adam@4 122 fun rows year month day =
adam@4 123 let
adam@4 124 fun row year month day weekday =
adam@4 125 if weekday >= 7 then
adam@4 126 <xml/>
adam@4 127 else
adam@4 128 <xml>
adam@4 129 <dyn signal={let
adam@4 130 val thisDate = {Year = year,
adam@4 131 Month = case month of
adam@4 132 Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
adam@4 133 | This => minf.ThisMonth
adam@4 134 | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
adam@4 135 Day = day}
adam@4 136 in
adam@4 137 cday <- signal t.Day;
adam@4 138 return (if Record.equal thisDate cday then
adam@4 139 <xml><td class={selday}>{[day]}</td></xml>
adam@4 140 else case month of
adam@4 141 This => <xml><td class={curday}
kkallio@12 142 onclick={action thisDate; set t.Day thisDate}>{[day]}</td></xml>
adam@4 143 | _ => <xml><td class={otherday}>{[day]}</td></xml>)
adam@4 144 end}/>
adam@4 145 {let
adam@4 146 val (year, month, day) =
adam@4 147 case month of
adam@4 148 Prev => if day = minf.PrevMonthLength then
adam@4 149 (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
adam@4 150 else
adam@4 151 (year, Prev, day+1)
adam@4 152 | This => if day = minf.ThisMonthLength then
adam@4 153 (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
adam@4 154 else
adam@4 155 (year, This, day+1)
adam@4 156 | Next => (year, Next, day+1)
adam@4 157 in
adam@4 158 row year month day (weekday+1)
adam@4 159 end}
adam@4 160 </xml>
adam@4 161 in
adam@4 162 case month of
adam@4 163 Next => <xml/>
adam@4 164 | _ =>
adam@4 165 <xml>
adam@4 166 <tr>{row year month day 0}</tr>
adam@4 167 {let
adam@4 168 val next =
adam@4 169 case month of
adam@4 170 Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
adam@4 171 | This =>
adam@4 172 Some (if day + 7 > minf.ThisMonthLength then
adam@4 173 (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
adam@4 174 else
adam@4 175 (year, This, day + 7))
adam@4 176 | Next => None
adam@2 177 in
adam@4 178 case next of
adam@4 179 None => <xml/>
adam@4 180 | Some (year, month, day) => rows year month day
adam@4 181 end}
adam@4 182 </xml>
adam@4 183 end
adam@4 184 in
adam@4 185 return <xml>
adam@4 186 <table class={calendar}>
adam@4 187 <tr>
adam@4 188 <th class={prev} colspan={2}
adam@4 189 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
adam@4 190 {Month = 12, Year = minf.Year - 1}
adam@4 191 else
adam@4 192 {Month = minf.ThisMonth - 1, Year = minf.Year}));
adam@4 193 set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
adam@4 194 <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
adam@4 195 <th class={next} colspan={2}
adam@4 196 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
adam@4 197 {Month = 1, Year = minf.Year + 1}
adam@4 198 else
adam@4 199 {Month = minf.ThisMonth + 1, Year = minf.Year}));
adam@4 200 set t.Month minf}>{[minf.NextMonthName]} >></th>
adam@4 201 </tr>
adam@4 202 <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>
adam@4 203 {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
adam@4 204 minf.Year - 1
adam@4 205 else
adam@4 206 minf.Year) minf.MondayMonth minf.MondayDay}
adam@4 207 </table>
adam@4 208 </xml>
adam@4 209 end
adam@2 210
adam@4 211 fun render t = <xml>
adam@4 212 <dyn signal={date <- signal t.Day;
adam@4 213 return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
adam@4 214 <dyn signal={hd <- signal t.Hide;
adam@4 215 if hd then
adam@4 216 return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
adam@4 217 else
kkallio@12 218 main <- render' (fn _ => return ()) (t -- #Hide);
adam@4 219 return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
adam@4 220 </xml>
adam@4 221
kkallio@12 222 type calendarCtl = $cal
kkallio@12 223
kkallio@12 224 fun givesDates_calendarCtl x = x.Day
kkallio@12 225
kkallio@12 226 fun createCalendarCtl tm =
kkallio@12 227 year <- return (readError (timef "%Y" tm));
kkallio@12 228 month <- return (readError (timef "%m" tm));
kkallio@12 229 minf <- source (monthInfo' {Month = month, Year = year});
kkallio@12 230 day <- return (readError (timef "%d" tm));
kkallio@12 231 day <- source {Year = year, Month = month, Day = day};
kkallio@12 232 return {Month = minf, Day = day}
kkallio@12 233
kkallio@12 234 fun renderCalendarCtl action ctl =
kkallio@12 235 <xml>
kkallio@12 236 <dyn signal={render' action ctl}/>
kkallio@12 237 </xml>
kkallio@12 238
kkallio@12 239 fun setCalendarCtl action ctl day =
kkallio@13 240 minf <- rpc (monthInfo (day -- #Day));
kkallio@12 241 action day;
kkallio@13 242 set ctl.Month minf;
kkallio@12 243 set ctl.Day day
kkallio@12 244
kkallio@12 245 fun value [t ::: Type] (gd : givesDates t) t = signal (gd t)