Mercurial > gui

annotate calendar.ur @ 29:93140c5cc972

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