--- a/datebox.ur	Sun Jul 24 14:51:16 2011 -0400
+++ b/datebox.ur	Thu Jul 28 10:24:34 2011 -0430
@@ -15,12 +15,17 @@
                       Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
                               y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
 
-type t = {Month : source {ThisMonth : int, Year : int,
-                          ThisMonthLength : int, PrevMonthLength : int,
-                          MondayMonth : month, MondayDay : int,
-                          PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
-          Day : source date,
-          Hide : source bool}
+con cal = [Month = source {ThisMonth : int, Year : int,
+                           ThisMonthLength : int, PrevMonthLength : int,
+                           MondayMonth : month, MondayDay : int,
+                           PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
+           Day = source date]
+
+class givesDates t = t -> source date
+
+type t = $(cal ++ [Hide = source bool])
+
+fun givesDates_t x = x.Day
 
 fun pad len n =
     let
@@ -36,6 +41,14 @@
     end
 
 fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
+fun date tm =
+    let
+        val y = readError (timef "%Y" tm)
+        val m = readError (timef "%m" tm)
+        val d = readError (timef "%d" tm)
+    in
+        {Year = y, Month = m, Day = d}
+    end
 
 fun monthLen m =
     let
@@ -103,7 +116,7 @@
     hide <- source True;
     return {Month = minf, Day = day, Hide = hide}
 
-fun render' t =
+fun render' action t =
     minf <- signal t.Month;
     let
         fun rows year month day =
@@ -126,7 +139,7 @@
                                                        <xml><td class={selday}>{[day]}</td></xml>
                                                    else case month of
                                                             This => <xml><td class={curday}
-                                                                                       onclick={set t.Day thisDate}>{[day]}</td></xml>
+                                                                                       onclick={action thisDate; set t.Day thisDate}>{[day]}</td></xml>
                                                           | _ => <xml><td class={otherday}>{[day]}</td></xml>)
                                        end}/>
                             {let
@@ -202,8 +215,29 @@
                if hd then
                    return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
                else
-                   main <- render' t;
+                   main <- render' (fn _ => return ()) (t -- #Hide);
                    return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
 </xml>
 
-fun value t = signal t.Day
+type calendarCtl = $cal
+
+fun givesDates_calendarCtl x = x.Day
+
+fun createCalendarCtl tm =
+    year <- return (readError (timef "%Y" tm));
+    month <- return (readError (timef "%m" tm));
+    minf <- source (monthInfo' {Month = month, Year = year});
+    day <- return (readError (timef "%d" tm));
+    day <- source {Year = year, Month = month, Day = day};
+    return {Month = minf, Day = day}
+
+fun renderCalendarCtl action ctl =
+    <xml>
+      <dyn signal={render' action ctl}/>
+    </xml>
+
+fun setCalendarCtl action ctl day =
+    action day;
+    set ctl.Day day
+
+fun value [t ::: Type] (gd : givesDates t) t = signal (gd t)