# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1297201949 18000
# Node ID 377c11586999e5d6fc7c653e3933efa019675e42
# Parent  8cab48efaff250823ec008064ba3b8a586ca636b
Fully-functional Datebox

diff -r 8cab48efaff2 -r 377c11586999 datebox.ur
--- a/datebox.ur	Tue Feb 08 16:06:31 2011 -0500
+++ b/datebox.ur	Tue Feb 08 16:52:29 2011 -0500
@@ -5,14 +5,18 @@
 style weekday
 style curday
 style otherday
+style selday
 
 datatype month = Prev | This | Next
 
+type date = {Year : int, Month : int, Day : int}
+
 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}
+          Day : source date,
+          Hide : source bool}
 
 fun pad len n =
     let
@@ -84,95 +88,116 @@
 
 fun monthInfo this = return (monthInfo' this)
 
-val create =
-    tm <- now;
+fun create tm =
     year <- return (readError (timef "%Y" tm));
     month <- return (readError (timef "%m" tm));
-    month <- source (monthInfo' {Month = month, Year = year});
+    minf <- source (monthInfo' {Month = month, Year = year});
     day <- return (readError (timef "%d" tm));
-    day <- source day;
-    return {Month = month, Day = day}
+    day <- source {Year = year, Month = month, Day = day};
+    hide <- source True;
+    return {Month = minf, Day = day, Hide = hide}
 
-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>
+fun render' t =
+    minf <- signal t.Month;
+    let
+        fun rows year month day =
+            let
+                fun row year month day weekday =
+                    if weekday >= 7 then
+                        <xml/>
+                    else
+                        <xml>
+                          <dyn signal={let
+                                           val thisDate = {Year = year,
+                                                           Month = case month of
+                                                                       Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
+                                                                     | This => minf.ThisMonth
+                                                                     | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
+                                                           Day = day}
+                                       in
+                                           cday <- signal t.Day;
+                                           return (if Record.equal thisDate cday then
+                                                       <xml><td class={selday}>{[day]}</td></xml>
+                                                   else case month of
+                                                            This => <xml><td class={curday}
+                                                                                       onclick={set t.Day thisDate}>{[day]}</td></xml>
+                                                          | _ => <xml><td class={otherday}>{[day]}</td></xml>)
+                                       end}/>
+                            {let
+                                 val (year, month, day) =
+                                     case month of
+                                         Prev => if day = minf.PrevMonthLength then
+                                                     (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
+                                                 else
+                                                     (year, Prev, day+1)
+                                       | This => if day = minf.ThisMonthLength then
+                                                     (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
+                                                 else
+                                                     (year, This, day+1)
+                                       | Next => (year, Next, day+1)
+                             in
+                                 row year month day (weekday+1)
+                             end}
+                          </xml>
+            in
+                case month of
+                    Next => <xml/>
+                  | _ =>
+                    <xml>
+                      <tr>{row year month day 0}</tr>
+                      {let
+                           val next =
+                               case month of
+                                   Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
+                                 | This =>
+                                   Some (if day + 7 > minf.ThisMonthLength then
+                                             (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
+                                         else
+                                             (year, This, day + 7))
+                                 | Next => None
                        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}
-                             onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
-                                                                  {Month = 12, Year = minf.Year - 1}
-                                                              else
-                                                                  {Month = minf.ThisMonth - 1, Year = minf.Year}));
-                                      set t.Day 1;
-                                      set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
-                         <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
-                         <th class={next} colspan={2}
-                             onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
-                                                                  {Month = 1, Year = minf.Year + 1}
-                                                              else
-                                                                  {Month = minf.ThisMonth + 1, Year = minf.Year}));
-                                      set t.Day 1;
-                                      set t.Month minf}>{[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>
+                           case next of
+                               None => <xml/>
+                             | Some (year, month, day) => rows year month day
+                       end}
+                    </xml>
+            end
+    in
+        return <xml>
+          <table class={calendar}>
+            <tr>
+              <th class={prev} colspan={2}
+                                           onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
+                                                                                {Month = 12, Year = minf.Year - 1}
+                                                                            else
+                                                                                {Month = minf.ThisMonth - 1, Year = minf.Year}));
+                                                    set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
+                                           <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
+                                           <th class={next} colspan={2}
+                                                                        onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
+                                                                                                             {Month = 1, Year = minf.Year + 1}
+                                                                                                         else
+                                                                                                             {Month = minf.ThisMonth + 1, Year = minf.Year}));
+                                                                                 set t.Month minf}>{[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 (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
+                       minf.Year - 1
+                   else
+                       minf.Year) minf.MondayMonth minf.MondayDay}
+          </table>
+        </xml>
+    end
 
-fun value t =
-    month <- signal t.Month;
-    day <- signal t.Day;
-    return {Year = month.Year, Month = month.ThisMonth, Day = day}
+fun render t = <xml>
+  <dyn signal={date <- signal t.Day;
+               return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
+  <dyn signal={hd <- signal t.Hide;
+               if hd then
+                   return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
+               else
+                   main <- render' t;
+                   return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
+</xml>
+
+fun value t = signal t.Day
diff -r 8cab48efaff2 -r 377c11586999 datebox.urs
--- a/datebox.urs	Tue Feb 08 16:06:31 2011 -0500
+++ b/datebox.urs	Tue Feb 08 16:52:29 2011 -0500
@@ -1,8 +1,10 @@
 type t
 
-val create : transaction t
+type date = {Year : int, Month : int, Day : int}
+
+val create : time -> transaction t
 val render : t -> xbody
-val value : t -> signal {Year : int, Month : int, Day : int}
+val value : t -> signal date
 
 style calendar
 style prev
@@ -11,3 +13,4 @@
 style weekday
 style curday
 style otherday
+style selday
diff -r 8cab48efaff2 -r 377c11586999 lib.urp
--- a/lib.urp	Tue Feb 08 16:06:31 2011 -0500
+++ b/lib.urp	Tue Feb 08 16:52:29 2011 -0500
@@ -1,3 +1,5 @@
+library $META
+
 $/string
 $/list
 timer