Mercurial > gui

annotate datebox.ur @ 3:8cab48efaff2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Seeking through months with Datebox
author Adam Chlipala <adam@chlipala.net>
date Tue, 08 Feb 2011 16:06:31 -0500
parents 33c83ae7c9af
children 377c11586999
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@3 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@3 85 fun monthInfo this = return (monthInfo' this)
adam@3 86
adam@2 87 val create =
adam@2 88 tm <- now;
adam@2 89 year <- return (readError (timef "%Y" tm));
adam@2 90 month <- return (readError (timef "%m" tm));
adam@3 91 month <- source (monthInfo' {Month = month, Year = year});
adam@2 92 day <- return (readError (timef "%d" tm));
adam@2 93 day <- source day;
adam@2 94 return {Month = month, Day = day}
adam@2 95
adam@2 96 fun render (t : t) = <xml>
adam@2 97 <dyn signal={minf <- signal t.Month;
adam@2 98 let
adam@2 99 fun rows month day =
adam@2 100 let
adam@2 101 fun row month day weekday =
adam@2 102 if weekday >= 7 then
adam@2 103 <xml/>
adam@2 104 else
adam@2 105 <xml>
adam@2 106 <td class={case month of
adam@2 107 This => curday
adam@2 108 | _ => otherday}>{[day]}</td>
adam@2 109 {let
adam@2 110 val (month, day) =
adam@2 111 case month of
adam@2 112 Prev => if day = minf.PrevMonthLength then
adam@2 113 (This, 1)
adam@2 114 else
adam@2 115 (Prev, day+1)
adam@2 116 | This => if day = minf.ThisMonthLength then
adam@2 117 (Next, 1)
adam@2 118 else
adam@2 119 (This, day+1)
adam@2 120 | Next => (Next, day+1)
adam@2 121 in
adam@2 122 row month day (weekday+1)
adam@2 123 end}
adam@2 124 </xml>
adam@2 125 in
adam@2 126 case month of
adam@2 127 Next => <xml/>
adam@2 128 | _ =>
adam@2 129 <xml>
adam@2 130 <tr>{row month day 0}</tr>
adam@2 131 {let
adam@2 132 val next =
adam@2 133 case month of
adam@2 134 Prev => Some (This, day + 7 - minf.PrevMonthLength)
adam@2 135 | This =>
adam@2 136 Some (if day + 7 > minf.ThisMonthLength then
adam@2 137 (Next, day + 7 - minf.ThisMonthLength)
adam@2 138 else
adam@2 139 (This, day + 7))
adam@2 140 | Next => None
adam@2 141 in
adam@2 142 case next of
adam@2 143 None => <xml/>
adam@2 144 | Some (month, day) => rows month day
adam@2 145 end}
adam@2 146 </xml>
adam@2 147 end
adam@2 148 in
adam@2 149 return <xml>
adam@2 150 <table class={calendar}>
adam@2 151 <tr>
adam@3 152 <th class={prev} colspan={2}
adam@3 153 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
adam@3 154 {Month = 12, Year = minf.Year - 1}
adam@3 155 else
adam@3 156 {Month = minf.ThisMonth - 1, Year = minf.Year}));
adam@3 157 set t.Day 1;
adam@3 158 set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
adam@3 159 <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
adam@3 160 <th class={next} colspan={2}
adam@3 161 onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
adam@3 162 {Month = 1, Year = minf.Year + 1}
adam@3 163 else
adam@3 164 {Month = minf.ThisMonth + 1, Year = minf.Year}));
adam@3 165 set t.Day 1;
adam@3 166 set t.Month minf}>{[minf.NextMonthName]} >></th>
adam@2 167 </tr>
adam@2 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>
adam@2 169 {rows minf.MondayMonth minf.MondayDay}
adam@2 170 </table>
adam@2 171 </xml>
adam@2 172 end}/>
adam@2 173 </xml>
adam@2 174
adam@2 175 fun value t =
adam@2 176 month <- signal t.Month;
adam@2 177 day <- signal t.Day;
adam@3 178 return {Year = month.Year, Month = month.ThisMonth, Day = day}