Mercurial > gui

annotate datebox.ur @ 2:33c83ae7c9af

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of datebox: calendarizing current month correctly
author Adam Chlipala <adam@chlipala.net>
date Tue, 08 Feb 2011 15:51:42 -0500
parents
children 8cab48efaff2
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@2 8
adam@2 9 datatype month = Prev | This | Next
adam@2 10
adam@2 11 type t = {Month : source {ThisMonth : int, Year : int,
adam@2 12 ThisMonthLength : int, PrevMonthLength : int,
adam@2 13 MondayMonth : month, MondayDay : int,
adam@2 14 PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
adam@2 15 Day : source int}
adam@2 16
adam@2 17 fun pad len n =
adam@2 18 let
adam@2 19 val s = show n
adam@2 20
adam@2 21 fun pad' len s =
adam@2 22 if len <= 0 then
adam@2 23 s
adam@2 24 else
adam@2 25 pad' (len-1) ("0" ^ s)
adam@2 26 in
adam@2 27 pad' (len - String.length s) s
adam@2 28 end
adam@2 29
adam@2 30 fun monthLen m =
adam@2 31 let
adam@2 32 fun f n tm =
adam@2 33 let
adam@2 34 val next = addSeconds tm (60 * 60 * 24)
adam@2 35 val nextMon = readError (timef "%m" next)
adam@2 36 in
adam@2 37 if nextMon = m.Month then
adam@2 38 f (n+1) next
adam@2 39 else
adam@2 40 n
adam@2 41 end
adam@2 42 in
adam@2 43 f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
adam@2 44 end
adam@2 45
adam@2 46 fun weekdayToNum s =
adam@2 47 case s of
adam@2 48 "Mon" => 0
adam@2 49 | "Tue" => 1
adam@2 50 | "Wed" => 2
adam@2 51 | "Thu" => 3
adam@2 52 | "Fri" => 4
adam@2 53 | "Sat" => 5
adam@2 54 | "Sun" => 6
adam@2 55 | _ => error <xml>Datebox: Bad weekday name</xml>
adam@2 56
adam@2 57 fun timeOfMonth my =
adam@2 58 readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
adam@2 59
adam@2 60 fun monthInfo this =
adam@2 61 let
adam@2 62 val prev = if this.Month = 1 then
adam@2 63 {Month = 12, Year = this.Year - 1}
adam@2 64 else
adam@2 65 {Month = this.Month-1, Year = this.Year}
adam@2 66 val prevLen = monthLen prev
adam@2 67
adam@2 68 val next = if this.Month = 12 then
adam@2 69 {Month = 1, Year = this.Year + 1}
adam@2 70 else
adam@2 71 {Month = this.Month + 1, Year = this.Year}
adam@2 72
adam@2 73 val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
adam@2 74 in
adam@2 75 {ThisMonth = this.Month, Year = this.Year,
adam@2 76 ThisMonthLength = monthLen this,
adam@2 77 PrevMonthLength = prevLen,
adam@2 78 MondayMonth = if firstDow = 0 then This else Prev,
adam@2 79 MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
adam@2 80 PrevMonthName = timef "%b" (timeOfMonth prev),
adam@2 81 ThisMonthName = timef "%b" (timeOfMonth this),
adam@2 82 NextMonthName = timef "%b" (timeOfMonth next)}
adam@2 83 end
adam@2 84
adam@2 85 val create =
adam@2 86 tm <- now;
adam@2 87 year <- return (readError (timef "%Y" tm));
adam@2 88 month <- return (readError (timef "%m" tm));
adam@2 89 month <- source (monthInfo {Month = month, Year = year});
adam@2 90 day <- return (readError (timef "%d" tm));
adam@2 91 day <- source day;
adam@2 92 return {Month = month, Day = day}
adam@2 93
adam@2 94 fun render (t : t) = <xml>
adam@2 95 <dyn signal={minf <- signal t.Month;
adam@2 96 let
adam@2 97 fun rows month day =
adam@2 98 let
adam@2 99 fun row month day weekday =
adam@2 100 if weekday >= 7 then
adam@2 101 <xml/>
adam@2 102 else
adam@2 103 <xml>
adam@2 104 <td class={case month of
adam@2 105 This => curday
adam@2 106 | _ => otherday}>{[day]}</td>
adam@2 107 {let
adam@2 108 val (month, day) =
adam@2 109 case month of
adam@2 110 Prev => if day = minf.PrevMonthLength then
adam@2 111 (This, 1)
adam@2 112 else
adam@2 113 (Prev, day+1)
adam@2 114 | This => if day = minf.ThisMonthLength then
adam@2 115 (Next, 1)
adam@2 116 else
adam@2 117 (This, day+1)
adam@2 118 | Next => (Next, day+1)
adam@2 119 in
adam@2 120 row month day (weekday+1)
adam@2 121 end}
adam@2 122 </xml>
adam@2 123 in
adam@2 124 case month of
adam@2 125 Next => <xml/>
adam@2 126 | _ =>
adam@2 127 <xml>
adam@2 128 <tr>{row month day 0}</tr>
adam@2 129 {let
adam@2 130 val next =
adam@2 131 case month of
adam@2 132 Prev => Some (This, day + 7 - minf.PrevMonthLength)
adam@2 133 | This =>
adam@2 134 Some (if day + 7 > minf.ThisMonthLength then
adam@2 135 (Next, day + 7 - minf.ThisMonthLength)
adam@2 136 else
adam@2 137 (This, day + 7))
adam@2 138 | Next => None
adam@2 139 in
adam@2 140 case next of
adam@2 141 None => <xml/>
adam@2 142 | Some (month, day) => rows month day
adam@2 143 end}
adam@2 144 </xml>
adam@2 145 end
adam@2 146 in
adam@2 147 return <xml>
adam@2 148 <table class={calendar}>
adam@2 149 <tr>
adam@2 150 <th class={prev} colspan={2}>&lt;&lt; {[minf.PrevMonthName]}</th>
adam@2 151 <th class={this} colspan={3}>{[minf.ThisMonthName]}</th>
adam@2 152 <th class={next} colspan={2}>{[minf.NextMonthName]} >></th>
adam@2 153 </tr>
adam@2 154 <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@2 155 {rows minf.MondayMonth minf.MondayDay}
adam@2 156 </table>
adam@2 157 </xml>
adam@2 158 end}/>
adam@2 159 </xml>
adam@2 160
adam@2 161 fun value t =
adam@2 162 month <- signal t.Month;
adam@2 163 day <- signal t.Day;
adam@2 164 return (readError (show month.Year ^ "-" ^ pad 2 month.ThisMonth ^ "-" ^ pad 2 day ^ " 00:00:00"))