Mercurial > gui
changeset 2:33c83ae7c9af
Start of datebox: calendarizing current month correctly
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Tue, 08 Feb 2011 15:51:42 -0500 |
| parents | 4d8165e8f89a |
| children | 8cab48efaff2 |
| files | datebox.ur datebox.urs lib.urp |
| diffstat | 3 files changed, 179 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/datebox.ur Tue Feb 08 15:51:42 2011 -0500 @@ -0,0 +1,164 @@ +style calendar +style prev +style this +style next +style weekday +style curday +style otherday + +datatype month = Prev | This | Next + +type t = {Month : source {ThisMonth : int, Year : int, + ThisMonthLength : int, PrevMonthLength : int, + MondayMonth : month, MondayDay : int, + PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, + Day : source int} + +fun pad len n = + let + val s = show n + + fun pad' len s = + if len <= 0 then + s + else + pad' (len-1) ("0" ^ s) + in + pad' (len - String.length s) s + end + +fun monthLen m = + let + fun f n tm = + let + val next = addSeconds tm (60 * 60 * 24) + val nextMon = readError (timef "%m" next) + in + if nextMon = m.Month then + f (n+1) next + else + n + end + in + f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00")) + end + +fun weekdayToNum s = + case s of + "Mon" => 0 + | "Tue" => 1 + | "Wed" => 2 + | "Thu" => 3 + | "Fri" => 4 + | "Sat" => 5 + | "Sun" => 6 + | _ => error <xml>Datebox: Bad weekday name</xml> + +fun timeOfMonth my = + readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00") + +fun monthInfo this = + let + val prev = if this.Month = 1 then + {Month = 12, Year = this.Year - 1} + else + {Month = this.Month-1, Year = this.Year} + val prevLen = monthLen prev + + val next = if this.Month = 12 then + {Month = 1, Year = this.Year + 1} + else + {Month = this.Month + 1, Year = this.Year} + + val firstDow = weekdayToNum (timef "%a" (timeOfMonth this)) + in + {ThisMonth = this.Month, Year = this.Year, + ThisMonthLength = monthLen this, + PrevMonthLength = prevLen, + MondayMonth = if firstDow = 0 then This else Prev, + MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1), + PrevMonthName = timef "%b" (timeOfMonth prev), + ThisMonthName = timef "%b" (timeOfMonth this), + NextMonthName = timef "%b" (timeOfMonth next)} + end + +val create = + tm <- now; + year <- return (readError (timef "%Y" tm)); + month <- return (readError (timef "%m" tm)); + month <- source (monthInfo {Month = month, Year = year}); + day <- return (readError (timef "%d" tm)); + day <- source day; + return {Month = month, Day = day} + +fun render (t : t) = <xml> + <dyn signal={minf <- signal t.Month; + let + fun rows month day = + let + fun row month day weekday = + if weekday >= 7 then + <xml/> + else + <xml> + <td class={case month of + This => curday + | _ => otherday}>{[day]}</td> + {let + val (month, day) = + case month of + Prev => if day = minf.PrevMonthLength then + (This, 1) + else + (Prev, day+1) + | This => if day = minf.ThisMonthLength then + (Next, 1) + else + (This, day+1) + | Next => (Next, day+1) + in + row month day (weekday+1) + end} + </xml> + in + case month of + Next => <xml/> + | _ => + <xml> + <tr>{row month day 0}</tr> + {let + val next = + case month of + Prev => Some (This, day + 7 - minf.PrevMonthLength) + | This => + Some (if day + 7 > minf.ThisMonthLength then + (Next, day + 7 - minf.ThisMonthLength) + else + (This, day + 7)) + | Next => None + in + case next of + None => <xml/> + | Some (month, day) => rows month day + end} + </xml> + end + in + return <xml> + <table class={calendar}> + <tr> + <th class={prev} colspan={2}><< {[minf.PrevMonthName]}</th> + <th class={this} colspan={3}>{[minf.ThisMonthName]}</th> + <th class={next} colspan={2}>{[minf.NextMonthName]} >></th> + </tr> + <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> + {rows minf.MondayMonth minf.MondayDay} + </table> + </xml> + end}/> + </xml> + +fun value t = + month <- signal t.Month; + day <- signal t.Day; + return (readError (show month.Year ^ "-" ^ pad 2 month.ThisMonth ^ "-" ^ pad 2 day ^ " 00:00:00"))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/datebox.urs Tue Feb 08 15:51:42 2011 -0500 @@ -0,0 +1,13 @@ +type t + +val create : transaction t +val render : t -> xbody +val value : t -> signal time + +style calendar +style prev +style this +style next +style weekday +style curday +style otherday