Merge with small clean-ups

author: Adam Chlipala <adam@chlipala.net> 2014-02-18 07:07:01 -0500
committer: Adam Chlipala <adam@chlipala.net> 2014-02-18 07:07:01 -0500
commit: a5299611e8a126a86a7f2121aa339d69a9fa5895 (patch)
tree: a7d9f1a32d92963d45c8ab93f0fec2396d973bd5
parent: 6337358bed21a199da8663fe198457c799e11467 (diff)
parent: a3c561f3daaffc39245c1aabee46f8cc22f375b8 (diff)
9 files changed, 312 insertions, 30 deletions
diff --git a/Makefile.am b/Makefile.am
index d626c267..11f9a132 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -95,13 +95,12 @@ if USE_EMACS
 endif
 
 uninstall-local-main:
-	rm -f $(DESTDIR)$(BIN)/urweb \
-		$(DESTDIR)$(LIB_UR)/basis.urs $(DESTDIR)$(LIB_UR)/char.urs $(DESTDIR)$(LIB_UR)/listPair.urs $(DESTDIR)$(LIB_UR)/list.urs \
-		$(DESTDIR)$(LIB_UR)/monad.urs $(DESTDIR)$(LIB_UR)/option.urs $(DESTDIR)$(LIB_UR)/string.urs $(DESTDIR)$(LIB_UR)/top.urs \
-		$(DESTDIR)$(LIB_UR)/char.ur $(DESTDIR)$(LIB_UR)/listPair.ur $(DESTDIR)$(LIB_UR)/list.ur \
-		$(DESTDIR)$(LIB_UR)/monad.ur $(DESTDIR)$(LIB_UR)/option.ur $(DESTDIR)$(LIB_UR)/string.ur $(DESTDIR)$(LIB_UR)/top.ur \
-		$(DESTDIR)$(LIB_JS)/urweb.js \
-		$(DESTDIR)$(INCLUDE)/config.h $(DESTDIR)$(INCLUDE)/queue.h $(DESTDIR)$(INCLUDE)/request.h $(DESTDIR)$(INCLUDE)/types.h \
+	rm -f $(DESTDIR)$(BIN)/urweb $(DESTDIR)$(LIB_UR)/basis.urs $(DESTDIR)$(LIB_UR)/char.urs $(DESTDIR)$(LIB_UR)/datetime.urs		\
+		$(DESTDIR)$(LIB_UR)/listPair.urs $(DESTDIR)$(LIB_UR)/list.urs $(DESTDIR)$(LIB_UR)/monad.urs					\
+		$(DESTDIR)$(LIB_UR)/option.urs $(DESTDIR)$(LIB_UR)/string.urs $(DESTDIR)$(LIB_UR)/top.urs $(DESTDIR)$(LIB_UR)/char.ur		\
+		$(DESTDIR)$(LIB_UR)/datetime.ur $(DESTDIR)$(LIB_UR)/listPair.ur $(DESTDIR)$(LIB_UR)/list.ur $(DESTDIR)$(LIB_UR)/monad.ur	\
+		$(DESTDIR)$(LIB_UR)/option.ur $(DESTDIR)$(LIB_UR)/string.ur $(DESTDIR)$(LIB_UR)/top.ur $(DESTDIR)$(LIB_JS)/urweb.js		\
+		$(DESTDIR)$(INCLUDE)/config.h $(DESTDIR)$(INCLUDE)/queue.h $(DESTDIR)$(INCLUDE)/request.h $(DESTDIR)$(INCLUDE)/types.h		\
 		$(DESTDIR)$(INCLUDE)/urweb.h $(DESTDIR)$(INCLUDE)/types_cpp.h $(DESTDIR)$(INCLUDE)/urweb_cpp.h
 
 uninstall-local: uninstall-local-main uninstall-emacs
diff --git a/demo/more/orm1.ur b/demo/more/orm1.ur
index b5ba29ac..989741dd 100644
--- a/demo/more/orm1.ur
+++ b/demo/more/orm1.ur
@@ -40,7 +40,7 @@ fun action () =
                                                       | Some r => <xml>{[r.B]}</xml>}
       </li></xml>) lsS}
     </body></xml>
-    
+
 fun main () = return <xml><body>
   <form><submit action={action}/></form>
 </body></xml>
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 1943a9f9..1bb6b2f2 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -268,6 +268,14 @@ uw_Basis_int uw_Basis_diffInSeconds(struct uw_context *, uw_Basis_time, uw_Basis
 uw_Basis_int uw_Basis_toSeconds(struct uw_context *, uw_Basis_time);
 uw_Basis_int uw_Basis_diffInMilliseconds(struct uw_context *, uw_Basis_time, uw_Basis_time);
 uw_Basis_int uw_Basis_toMilliseconds(struct uw_context *, uw_Basis_time);
+uw_Basis_time uw_Basis_fromDatetime(struct uw_context *, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int);
+uw_Basis_int uw_Basis_datetimeYear(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeMonth(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeDay(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeHour(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeMinute(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeSecond(struct uw_context *, uw_Basis_time);
+uw_Basis_int uw_Basis_datetimeDayOfWeek(struct uw_context *, uw_Basis_time);
 extern const uw_Basis_time uw_Basis_minTime;
 
 void uw_register_transactional(struct uw_context *, void *data, uw_callback commit, uw_callback rollback, uw_callback_with_retry free);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 6830945a..2e350378 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -217,13 +217,13 @@ var Dt = {
 	    var y = d.getFullYear();
 	    var V = parseInt(Dt.formats.V(d), 10);
 	    var W = parseInt(Dt.formats.W(d), 10);
-	    
+
 	    if(W > V) {
 		y++;
 	    } else if(W===0 && V>=52) {
 		y--;
 	    }
-	    
+
 	    return y;
 	},
 	H: ["getHours", "0"],
@@ -262,7 +262,7 @@ var Dt = {
 	    {
 		idow = Dt.formats.V(new Date("" + (d.getFullYear()-1) + "/12/31"));
 	    }
-	    
+
 	    return xPad(idow, 0);
 	},
 	w: "getDay",
@@ -345,7 +345,39 @@ function strftime(fmt, thisTime)
     var thisDate = new Date();
     thisDate.setTime(Math.floor(thisTime / 1000));
     return Dt.format(thisDate, fmt);
-}; 
+};
+
+function fromDatetime(year, month, date, hour, minute, second) {
+  return (new Date(year, month, date, hour, minute, second)).getTime() * 1000;
+};
+
+function datetimeYear(t) {
+  return (new Date(t / 1000)).getYear() + 1900;
+};
+
+function datetimeMonth(t) {
+  return (new Date(t / 1000)).getMonth();
+};
+
+function datetimeDay(t) {
+  return (new Date(t / 1000)).getDate();
+};
+
+function datetimeHour(t) {
+  return (new Date(t / 1000)).getHours();
+};
+
+function datetimeMinute(t) {
+  return (new Date(t / 1000)).getMinutes();
+};
+
+function datetimeSecond(t) {
+  return (new Date(t / 1000)).getSeconds();
+};
+
+function datetimeDayOfWeek(t) {
+  return (new Date(t / 1000)).getDay();
+};
 
 
 // Error handling
@@ -717,7 +749,7 @@ function runScripts(node) {
     if (node.tagName == "SCRIPT") {
         var savedScript = thisScript;
         thisScript = node;
-        
+
         try {
             eval(thisScript.text);
         } catch (v) {
@@ -1102,7 +1134,7 @@ function dynClass(html, s_class, s_style) {
         x.signal = s_class;
         x.sources = null;
         x.closures = htmlCls;
-        
+
         x.recreate = function(v) {
             for (var ls = x.closures; ls != htmlCls; ls = ls.next)
                 freeClosure(ls.data);
@@ -1123,7 +1155,7 @@ function dynClass(html, s_class, s_style) {
         x.signal = s_style;
         x.sources = null;
         x.closures = htmlCls2;
-        
+
         x.recreate = function(v) {
             for (var ls = x.closures; ls != htmlCls2; ls = ls.next)
                 freeClosure(ls.data);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index eefb5d2c..c94f2ba6 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -167,6 +167,16 @@ val diffInMilliseconds : time -> time -> int
 val timef : string -> time -> string (* Uses strftime() format string *)
 val readUtc : string -> option time
 
+(* Takes a year, month, day, hour, minute, second. *)
+val fromDatetime : int -> int -> int -> int -> int -> int -> time
+val datetimeYear : time -> int
+val datetimeMonth : time -> int
+val datetimeDay : time -> int
+val datetimeHour : time -> int
+val datetimeMinute: time -> int
+val datetimeSecond : time -> int
+val datetimeDayOfWeek : time -> int
+
 
 (** * Encryption *)
 
diff --git a/lib/ur/datetime.ur b/lib/ur/datetime.ur
new file mode 100644
index 00000000..9aeab291
--- /dev/null
+++ b/lib/ur/datetime.ur
@@ -0,0 +1,135 @@
+datatype day_of_week = Sunday | Monday | Tuesday | Wednesday | Thursday |
+         Friday | Saturday
+
+val show_day_of_week = mkShow (fn dow => case dow of
+                                          Sunday => "Sunday"
+                                        | Monday => "Monday"
+                                        | Tuesday => "Tuesday"
+                                        | Wednesday => "Wednesday"
+                                        | Thursday => "Thursday"
+                                        | Friday => "Friday"
+                                        | Saturday => "Saturday")
+
+fun dayOfWeekToInt dow = case dow of
+                             Sunday => 0
+                           | Monday => 1
+                           | Tuesday => 2
+                           | Wednesday => 3
+                           | Thursday => 4
+                           | Friday => 5
+                           | Saturday => 6
+
+fun intToDayOfWeek i = case i of
+                           0 => Sunday
+                         | 1 => Monday
+                         | 2 => Tuesday
+                         | 3 => Wednesday
+                         | 4 => Thursday
+                         | 5 => Friday
+                         | 6 => Saturday
+                         | n => error <xml>Invalid day of week {[n]}</xml>
+
+val eq_day_of_week = mkEq (fn a b => dayOfWeekToInt a = dayOfWeekToInt b)
+
+
+datatype month = January | February | March | April | May | June | July |
+         August | September | October | November | December
+
+val show_month = mkShow (fn m => case m of
+                                     January => "January"
+                                   | February => "February"
+                                   | March => "March"
+                                   | April => "April"
+                                   | May => "May"
+                                   | June => "June"
+                                   | July => "July"
+                                   | August => "August"
+                                   | September => "September"
+                                   | October => "October"
+                                   | November => "November"
+                                   | December => "December")
+
+type t = {
+     Year : int,
+     Month : month,
+     Day : int,
+     Hour : int,
+     Minute : int,
+     Second : int
+}
+
+fun monthToInt m = case m of
+                       January => 0
+                     | February => 1
+                     | March => 2
+                     | April => 3
+                     | May => 4
+                     | June => 5
+                     | July => 6
+                     | August => 7
+                     | September => 8
+                     | October => 9
+                     | November => 10
+                     | December => 11
+
+fun intToMonth i = case i of
+                       0 => January
+                     | 1 => February
+                     | 2 => March
+                     | 3 => April
+                     | 4 => May
+                     | 5 => June
+                     | 6 => July
+                     | 7 => August
+                     | 8 => September
+                     | 9 => October
+                     | 10 => November
+                     | 11 => December
+                     | n => error <xml>Invalid month number {[n]}</xml>
+
+val eq_month = mkEq (fn a b => monthToInt a = monthToInt b)
+
+
+fun toTime dt : time = fromDatetime dt.Year (monthToInt dt.Month) dt.Day
+                                    dt.Hour dt.Minute dt.Second
+
+fun fromTime t : t = {
+    Year = datetimeYear t,
+    Month = intToMonth (datetimeMonth t),
+    Day = datetimeDay t,
+    Hour = datetimeHour t,
+    Minute = datetimeMinute t,
+    Second = datetimeSecond t
+}
+
+val ord_datetime = mkOrd { Lt = fn a b => toTime a < toTime b,
+                           Le = fn a b => toTime a <= toTime b }
+
+fun format fmt dt : string = timef fmt (toTime dt)
+
+fun dayOfWeek dt : day_of_week = intToDayOfWeek (datetimeDayOfWeek (toTime dt))
+
+val now : transaction t =
+    n <- now;
+    return (fromTime n)
+
+(* Normalize a datetime. This will convert, e.g., January 32nd into February
+   1st. *)
+
+fun normalize dt = fromTime (toTime dt)
+fun addToField [nm :: Name] [rest ::: {Type}] [[nm] ~ rest]
+               (delta : int) (r : $([nm = int] ++ rest))
+    : $([nm = int] ++ rest) =
+      (r -- nm) ++ {nm = r.nm + delta}
+
+
+(* Functions for adding to a datetime. There is no addMonths or addYears since
+   it's not clear what should be done; what's 1 month after January 31, or 1
+   year after February 29th?
+
+   These can't all be defined in terms of addSeconds because of leap seconds. *)
+
+fun addSeconds n dt = normalize (addToField [#Second] n dt)
+fun addMinutes n dt = normalize (addToField [#Minute] n dt)
+fun addHours n dt = normalize (addToField [#Hour] n dt)
+fun addDays n dt = normalize (addToField [#Day] n dt)
diff --git a/lib/ur/datetime.urs b/lib/ur/datetime.urs
new file mode 100644
index 00000000..972f86bf
--- /dev/null
+++ b/lib/ur/datetime.urs
@@ -0,0 +1,38 @@
+datatype day_of_week = Sunday | Monday | Tuesday | Wednesday | Thursday |
+         Friday | Saturday
+
+datatype month = January | February | March | April | May | June | July |
+         August | September | October | November | December
+
+
+type t = {
+     Year : int,
+     Month : month,
+     Day : int,
+     Hour : int,
+     Minute : int,
+     Second : int
+}
+
+val ord_datetime : ord t
+
+val show_day_of_week : show day_of_week
+val show_month : show month
+val eq_day_of_week : eq day_of_week
+val eq_month : eq month
+val dayOfWeekToInt : day_of_week -> int
+val intToDayOfWeek : int -> day_of_week
+val monthToInt : month -> int
+val intToMonth : int -> month
+
+val toTime : t -> time
+val fromTime : time -> t
+val format : string -> t -> string
+val dayOfWeek : t -> day_of_week
+val now : transaction t
+val normalize : t -> t
+
+val addSeconds : int -> t -> t
+val addMinutes : int -> t -> t
+val addHours : int -> t -> t
+val addDays : int -> t -> t
diff --git a/src/c/urweb.c b/src/c/urweb.c
index c0c339c1..7ff8a262 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -847,7 +847,7 @@ static void adjust_input(input *x, input *old_start, input *new_start, size_t le
     break;
   default:
     break;
-  }  
+  }
 }
 
 size_t uw_subinputs_max = SIZE_MAX;
@@ -1863,12 +1863,12 @@ uw_unit uw_Basis_urlifyInt_w(uw_context ctx, uw_Basis_int n) {
 uw_unit uw_Basis_urlifyChannel_w(uw_context ctx, uw_Basis_channel chn) {
   if (ctx->client != NULL && chn.cli == ctx->client->id) {
     int len;
-    
+
     uw_check(ctx, INTS_MAX + 1);
     sprintf(ctx->page.front, "%u%n", chn.chn, &len);
     ctx->page.front += len;
   }
-    
+
   return uw_unit_v;
 }
 
@@ -1929,11 +1929,11 @@ uw_unit uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) {
 
 uw_unit uw_Basis_urlifySource_w(uw_context ctx, uw_Basis_source src) {
   int len;
-    
+
   uw_check(ctx, 2 * INTS_MAX + 2);
   sprintf(ctx->page.front, "%d/%llu%n", src.context, src.source, &len);
   ctx->page.front += len;
-    
+
   return uw_unit_v;
 }
 
@@ -2024,7 +2024,7 @@ static uw_Basis_string uw_unurlifyString_to(int fromClient, uw_context ctx, char
 uw_Basis_bool uw_Basis_unurlifyBool(uw_context ctx, char **s) {
   char *new_s = uw_unurlify_advance(*s);
   uw_Basis_bool r;
-  
+
   if (*s[0] == 0 || !strcmp(*s, "0") || !strcmp(*s, "off"))
     r = uw_Basis_False;
   else
@@ -2085,7 +2085,7 @@ uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) {
   uw_check(ctx, INTS_MAX);
   sprintf(ctx->page.front, "%lld%n", n, &len);
   ctx->page.front += len;
-  
+
   return uw_unit_v;
 }
 
@@ -2149,7 +2149,7 @@ uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_int n) {
   uw_check(ctx, INTS_MAX);
   sprintf(ctx->page.front, "%lld%n", (uw_Basis_int)n, &len);
   ctx->page.front += len;
-  
+
   return uw_unit_v;
 }
 
@@ -2253,7 +2253,7 @@ uw_unit uw_Basis_htmlifySource_w(uw_context ctx, uw_Basis_source src) {
   uw_check(ctx, 2 * INTS_MAX + 1);
   sprintf(ctx->page.front, "s%d_%llu%n", src.context, src.source, &len);
   ctx->page.front += len;
-  
+
   return uw_unit_v;
 }
 
@@ -2363,7 +2363,7 @@ uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_i
     r[len] = 0;
     return r;
   }
-    
+
 }
 
 uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) {
@@ -2587,7 +2587,7 @@ uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) {
       sprintf(s2, "%02X", c);
       s2 += 2;
     }
-  }    
+  }
 
   *s2++ = '\'';
   strcpy(s2, uw_sqlsuffixBlob);
@@ -3254,7 +3254,7 @@ static char *find_sig(char *haystack) {
 
   if (!s || strlen(haystack) - (s - haystack) - (sizeof sig_intro - 1) < uw_hash_blocksize*2+1)
     return NULL;
-  
+
   s += sizeof sig_intro - 1;
 
   for (i = 0; i < uw_hash_blocksize*2; ++i)
@@ -3667,7 +3667,7 @@ uw_Basis_string uw_unnull(uw_Basis_string s) {
 uw_Basis_string uw_Basis_makeSigString(uw_context ctx, uw_Basis_string sig) {
   uw_Basis_string r = uw_malloc(ctx, 2 * uw_hash_blocksize + 1);
   int i;
-  
+
   for (i = 0; i < uw_hash_blocksize; ++i)
     sprintf(&r[2*i], "%.02X", ((unsigned char *)sig)[i]);
 
@@ -3885,7 +3885,7 @@ uw_Basis_string uw_Basis_mstrcat(uw_context ctx, ...) {
   va_list ap;
   size_t len = 1;
   char *s, *r, *s2;
-  
+
   va_start(ap, ctx);
   for (s = va_arg(ap, char*); s; s = va_arg(ap, char*))
     len += strlen(s);
@@ -3930,6 +3930,56 @@ uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) {
   return tm.seconds;
 }
 
+uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) {
+  struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day,
+                   .tm_hour = hour, .tm_min = minute, .tm_sec = second };
+  uw_Basis_time r = { timelocal(&tm) };
+  return r;
+}
+
+uw_Basis_int uw_Basis_datetimeYear(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_year + 1900;
+}
+
+uw_Basis_int uw_Basis_datetimeMonth(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_mon;
+}
+
+uw_Basis_int uw_Basis_datetimeDay(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_mday;
+}
+
+uw_Basis_int uw_Basis_datetimeHour(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_hour;
+}
+
+uw_Basis_int uw_Basis_datetimeMinute(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_min;
+}
+
+uw_Basis_int uw_Basis_datetimeSecond(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_sec;
+}
+
+uw_Basis_int uw_Basis_datetimeDayOfWeek(uw_context ctx, uw_Basis_time time) {
+  struct tm tm;
+  localtime_r(&time.seconds, &tm);
+  return tm.tm_wday;
+}
+
+
 void *uw_get_global(uw_context ctx, char *name) {
   int i;
 
@@ -4067,7 +4117,7 @@ uw_Basis_int uw_Basis_rand(uw_context ctx) {
   pthread_mutex_lock(&rand_mutex);
   int r = RAND_bytes((unsigned char *)&ret, sizeof ret);
   pthread_mutex_unlock(&rand_mutex);
-  
+
   if (r)
     return abs(ret);
   else
diff --git a/src/settings.sml b/src/settings.sml
index 020ca5a4..6282577d 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -331,6 +331,16 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("toMilliseconds", "toMilliseconds"),
                           ("diffInMilliseconds", "diffInMilliseconds"),
 
+                          ("fromDatetime", "fromDatetime"),
+                          ("datetimeYear", "datetimeYear"),
+                          ("datetimeMonth", "datetimeMonth"),
+                          ("datetimeDay", "datetimeDay"),
+                          ("datetimeHour", "datetimeHour"),
+                          ("datetimeMinute", "datetimeMinute"),
+                          ("datetimeSecond", "datetimeSecond"),
+                          ("datetimeDayOfWeek", "datetimeDayOfWeek"),
+
+
                           ("onClick", "uw_onClick"),
                           ("onDblclick", "uw_onDblclick"),
                           ("onKeydown", "uw_onKeydown"),
author	Adam Chlipala <adam@chlipala.net>	2014-02-18 07:07:01 -0500
committer	Adam Chlipala <adam@chlipala.net>	2014-02-18 07:07:01 -0500
commit	a5299611e8a126a86a7f2121aa339d69a9fa5895 (patch)
tree	a7d9f1a32d92963d45c8ab93f0fec2396d973bd5
parent	6337358bed21a199da8663fe198457c799e11467 (diff)
parent	a3c561f3daaffc39245c1aabee46f8cc22f375b8 (diff)