# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1297198302 18000
# Node ID 33c83ae7c9af6462fa3e49bd709246da69d8148c
# Parent  4d8165e8f89a1ea35888a918d94c2b4d995271d6
Start of datebox: calendarizing current month correctly

diff -r 4d8165e8f89a -r 33c83ae7c9af datebox.ur
--- /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}>&lt;&lt; {[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"))
diff -r 4d8165e8f89a -r 33c83ae7c9af datebox.urs
--- /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
diff -r 4d8165e8f89a -r 33c83ae7c9af lib.urp
--- a/lib.urp	Thu Jan 06 16:45:47 2011 -0500
+++ b/lib.urp	Tue Feb 08 15:51:42 2011 -0500
@@ -1,5 +1,7 @@
+$/string
 $/list
 timer
 waitbox
 select
 forms
+datebox