# HG changeset patch
# User Karn Kallio <kkallio@eka>
# Date 1311864874 16200
# Node ID bbdedfde154efa507a2d2a72d332ce5af25acf51
# Parent  ccd0a169e8277f92acedbe0b6d9e82ae521adf8f
Add a calendar control.

diff -r ccd0a169e827 -r bbdedfde154e datebox.ur
--- 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)
diff -r ccd0a169e827 -r bbdedfde154e datebox.urs
--- a/datebox.urs	Sun Jul 24 14:51:16 2011 -0400
+++ b/datebox.urs	Thu Jul 28 10:24:34 2011 -0430
@@ -1,12 +1,24 @@
+class givesDates
+
 type t
+type calendarCtl
+
+val givesDates_t : givesDates t
+val givesDates_calendarCtl : givesDates calendarCtl
 
 type date = {Year : int, Month : int, Day : int}
 val date_ord : ord date
 val time : date -> time
+val date : time -> date
 
 val create : time -> transaction t
 val render : t -> xbody
-val value : t -> signal date
+
+val createCalendarCtl : time -> transaction calendarCtl
+val renderCalendarCtl : (date -> transaction unit) -> calendarCtl -> xbody
+val setCalendarCtl : (date -> transaction unit) -> calendarCtl -> date -> transaction unit
+
+val value : t ::: Type -> givesDates t -> t -> signal date
 
 style calendar
 style prev
diff -r ccd0a169e827 -r bbdedfde154e examples/datebox.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/datebox.ur	Thu Jul 28 10:24:34 2011 -0430
@@ -0,0 +1,13 @@
+fun main () =
+
+tm <- now;
+
+dayCtl <- Datebox.createCalendarCtl tm;
+
+return
+    <xml>
+      <head><title>Datebox Example</title></head>
+      <body>
+        {Datebox.renderCalendarCtl (fn (d : Datebox.date) => alert (show d.Year)) dayCtl}
+      </body>
+    </xml>
diff -r ccd0a169e827 -r bbdedfde154e examples/datebox.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/datebox.urp	Thu Jul 28 10:24:34 2011 -0430
@@ -0,0 +1,7 @@
+path META=../../meta
+library ../
+rewrite url Datebox/*
+allow url http://*
+prefix http://localhost:8080/
+
+datebox
diff -r ccd0a169e827 -r bbdedfde154e examples/datebox.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/datebox.urs	Thu Jul 28 10:24:34 2011 -0430
@@ -0,0 +1,1 @@
+val main : unit -> transaction page