# HG changeset patch # User Adam Chlipala # Date 1220185938 14400 # Node ID 71bafe66dbe177f566b57608402bd22e1d4506ec # Parent 2b9dfaffb008d814ae461324a10c42a24f796bb0 Laconic -> Ur diff -r 2b9dfaffb008 -r 71bafe66dbe1 .hgignore --- a/.hgignore Thu Aug 28 14:48:33 2008 -0400 +++ b/.hgignore Sun Aug 31 08:32:18 2008 -0400 @@ -6,8 +6,8 @@ bin/* -src/lacweb.cm -src/lacweb.mlb +src/urweb.cm +src/urweb.mlb *.lex.* *.grm.* diff -r 2b9dfaffb008 -r 71bafe66dbe1 Makefile --- a/Makefile Thu Aug 28 14:48:33 2008 -0400 +++ b/Makefile Sun Aug 31 08:32:18 2008 -0400 @@ -2,31 +2,31 @@ .PHONY: all smlnj mlton c clean -smlnj: src/lacweb.cm -mlton: bin/lacweb -c: clib/lacweb.o clib/driver.o +smlnj: src/urweb.cm +mlton: bin/urweb +c: clib/urweb.o clib/driver.o clean: rm -f src/*.mlton.grm.* src/*.mlton.lex.* \ - src/lacweb.cm src/lacweb.mlb \ + src/urweb.cm src/urweb.mlb \ clib/*.o rm -rf .cm src/.cm -clib/lacweb.o: src/c/lacweb.c - gcc -O3 -I include -c src/c/lacweb.c -o clib/lacweb.o +clib/urweb.o: src/c/urweb.c + gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o clib/driver.o: src/c/driver.c gcc -O3 -I include -c src/c/driver.c -o clib/driver.o -src/lacweb.cm: src/prefix.cm src/sources +src/urweb.cm: src/prefix.cm src/sources cat src/prefix.cm src/sources \ - >src/lacweb.cm + >src/urweb.cm -src/lacweb.mlb: src/prefix.mlb src/sources src/suffix.mlb +src/urweb.mlb: src/prefix.mlb src/sources src/suffix.mlb cat src/prefix.mlb src/sources src/suffix.mlb \ | sed 's/^\(.*\).grm$$/\1.mlton.grm.sig\n\1.mlton.grm.sml/' \ | sed 's/^\(.*\).lex$$/\1.mlton.lex.sml/' \ - >src/lacweb.mlb + >src/urweb.mlb %.mlton.lex: %.lex cp $< $@ @@ -45,7 +45,7 @@ MLTON += -const 'Exn.keepHistory true' endif -bin/lacweb: src/lacweb.mlb src/*.sig src/*.sml \ - src/lacweb.mlton.lex.sml \ - src/lacweb.mlton.grm.sig src/lacweb.mlton.grm.sml - $(MLTON) -output $@ src/lacweb.mlb +bin/urweb: src/urweb.mlb src/*.sig src/*.sml \ + src/urweb.mlton.lex.sml \ + src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml + $(MLTON) -output $@ src/urweb.mlb diff -r 2b9dfaffb008 -r 71bafe66dbe1 include/lacweb.h --- a/include/lacweb.h Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -#include - -#include "types.h" - -int lw_really_send(int sock, void *buf, ssize_t len); - -extern lw_unit lw_unit_v; - -lw_context lw_init(size_t page_len, size_t heap_len); -void lw_free(lw_context); -void lw_reset(lw_context); -void lw_reset_keep_request(lw_context); -void lw_reset_keep_error_message(lw_context); -failure_kind lw_begin(lw_context, char *path); - -void lw_error(lw_context, failure_kind, const char *fmt, ...); -char *lw_error_message(lw_context); - -void *lw_malloc(lw_context, size_t); -int lw_send(lw_context, int sock); - -void lw_set_input(lw_context, char *name, char *value); -char *lw_get_input(lw_context, int name); -char *lw_get_optional_input(lw_context, int name); - -void lw_write(lw_context, const char*); - - -char *lw_Basis_htmlifyString(lw_context, lw_Basis_string); -void lw_Basis_htmlifyString_w(lw_context, lw_Basis_string); - -char *lw_Basis_attrifyInt(lw_context, lw_Basis_int); -char *lw_Basis_attrifyFloat(lw_context, lw_Basis_float); -char *lw_Basis_attrifyString(lw_context, lw_Basis_string); - -void lw_Basis_attrifyInt_w(lw_context, lw_Basis_int); -void lw_Basis_attrifyFloat_w(lw_context, lw_Basis_float); -void lw_Basis_attrifyString_w(lw_context, lw_Basis_string); - - -char *lw_Basis_urlifyInt(lw_context, lw_Basis_int); -char *lw_Basis_urlifyFloat(lw_context, lw_Basis_float); -char *lw_Basis_urlifyString(lw_context, lw_Basis_string); -char *lw_Basis_urlifyBool(lw_context, lw_Basis_bool); - -void lw_Basis_urlifyInt_w(lw_context, lw_Basis_int); -void lw_Basis_urlifyFloat_w(lw_context, lw_Basis_float); -void lw_Basis_urlifyString_w(lw_context, lw_Basis_string); -void lw_Basis_urlifyBool_w(lw_context, lw_Basis_bool); - -lw_Basis_int lw_Basis_unurlifyInt(lw_context, char **); -lw_Basis_float lw_Basis_unurlifyFloat(lw_context, char **); -lw_Basis_string lw_Basis_unurlifyString(lw_context, char **); -lw_Basis_bool lw_Basis_unurlifyBool(lw_context, char **); - -lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string); diff -r 2b9dfaffb008 -r 71bafe66dbe1 include/urweb.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/include/urweb.h Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,56 @@ +#include + +#include "types.h" + +int lw_really_send(int sock, void *buf, ssize_t len); + +extern lw_unit lw_unit_v; + +lw_context lw_init(size_t page_len, size_t heap_len); +void lw_free(lw_context); +void lw_reset(lw_context); +void lw_reset_keep_request(lw_context); +void lw_reset_keep_error_message(lw_context); +failure_kind lw_begin(lw_context, char *path); + +void lw_error(lw_context, failure_kind, const char *fmt, ...); +char *lw_error_message(lw_context); + +void *lw_malloc(lw_context, size_t); +int lw_send(lw_context, int sock); + +void lw_set_input(lw_context, char *name, char *value); +char *lw_get_input(lw_context, int name); +char *lw_get_optional_input(lw_context, int name); + +void lw_write(lw_context, const char*); + + +char *lw_Basis_htmlifyString(lw_context, lw_Basis_string); +void lw_Basis_htmlifyString_w(lw_context, lw_Basis_string); + +char *lw_Basis_attrifyInt(lw_context, lw_Basis_int); +char *lw_Basis_attrifyFloat(lw_context, lw_Basis_float); +char *lw_Basis_attrifyString(lw_context, lw_Basis_string); + +void lw_Basis_attrifyInt_w(lw_context, lw_Basis_int); +void lw_Basis_attrifyFloat_w(lw_context, lw_Basis_float); +void lw_Basis_attrifyString_w(lw_context, lw_Basis_string); + + +char *lw_Basis_urlifyInt(lw_context, lw_Basis_int); +char *lw_Basis_urlifyFloat(lw_context, lw_Basis_float); +char *lw_Basis_urlifyString(lw_context, lw_Basis_string); +char *lw_Basis_urlifyBool(lw_context, lw_Basis_bool); + +void lw_Basis_urlifyInt_w(lw_context, lw_Basis_int); +void lw_Basis_urlifyFloat_w(lw_context, lw_Basis_float); +void lw_Basis_urlifyString_w(lw_context, lw_Basis_string); +void lw_Basis_urlifyBool_w(lw_context, lw_Basis_bool); + +lw_Basis_int lw_Basis_unurlifyInt(lw_context, char **); +lw_Basis_float lw_Basis_unurlifyFloat(lw_context, char **); +lw_Basis_string lw_Basis_unurlifyString(lw_context, char **); +lw_Basis_bool lw_Basis_unurlifyBool(lw_context, char **); + +lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string); diff -r 2b9dfaffb008 -r 71bafe66dbe1 lib/basis.lig --- a/lib/basis.lig Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,249 +0,0 @@ -type int -type float -type string - -type unit = {} - -datatype bool = False | True - - -(** SQL *) - -con sql_table :: {Type} -> Type - -(*** Queries *) - -con sql_query :: {{Type}} -> {Type} -> Type -con sql_query1 :: {{Type}} -> {{Type}} -> {Type} -> Type -con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type - -con sql_subset :: {{Type}} -> {{Type}} -> Type -val sql_subset : keep_drop :: {({Type} * {Type})} - -> sql_subset - (fold (fn nm => fn fields :: ({Type} * {Type}) => fn acc => - [nm] ~ acc => fields.1 ~ fields.2 => - [nm = fields.1 ++ fields.2] ++ acc) [] keep_drop) - (fold (fn nm => fn fields :: ({Type} * {Type}) => fn acc => - [nm] ~ acc => - [nm = fields.1] ++ acc) [] keep_drop) -val sql_subset_all : tables :: {{Type}} - -> sql_subset tables tables - -val sql_query1 : tables ::: {{Type}} - -> grouped ::: {{Type}} - -> selectedFields ::: {{Type}} - -> selectedExps ::: {Type} - -> {From : $(fold (fn nm => fn fields :: {Type} => fn acc => - [nm] ~ acc => [nm = sql_table fields] ++ acc) [] tables), - Where : sql_exp tables [] [] bool, - GroupBy : sql_subset tables grouped, - Having : sql_exp grouped tables [] bool, - SelectFields : sql_subset grouped selectedFields, - SelectExps : $(fold (fn nm => fn t :: Type => fn acc => - [nm] ~ acc => [nm = sql_exp grouped tables [] t] ++ acc) [] selectedExps) } - -> sql_query1 tables selectedFields selectedExps - -type sql_relop -val sql_union : sql_relop -val sql_intersect : sql_relop -val sql_except : sql_relop -val sql_relop : sql_relop - -> tables1 ::: {{Type}} - -> tables2 ::: {{Type}} - -> selectedFields ::: {{Type}} - -> selectedExps ::: {Type} - -> sql_query1 tables1 selectedFields selectedExps - -> sql_query1 tables2 selectedFields selectedExps - -> sql_query1 selectedFields selectedFields selectedExps - -type sql_direction -val sql_asc : sql_direction -val sql_desc : sql_direction - -con sql_order_by :: {{Type}} -> {Type} -> Type -val sql_order_by_Nil : tables ::: {{Type}} -> exps :: {Type} -> sql_order_by tables exps -val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type - -> sql_exp tables [] exps t -> sql_order_by tables exps - -> sql_order_by tables exps - -type sql_limit -val sql_no_limit : sql_limit -val sql_limit : int -> sql_limit - -type sql_offset -val sql_no_offset : sql_offset -val sql_offset : int -> sql_offset - -val sql_query : tables ::: {{Type}} - -> selectedFields ::: {{Type}} - -> selectedExps ::: {Type} - -> {Rows : sql_query1 tables selectedFields selectedExps, - OrderBy : sql_order_by tables selectedExps, - Limit : sql_limit, - Offset : sql_offset} - -> sql_query selectedFields selectedExps - -val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type} -> fieldType ::: Type -> agg ::: {{Type}} - -> exps ::: {Type} - -> tab :: Name -> field :: Name - -> sql_exp ([tab = [field = fieldType] ++ otherFields] ++ otherTabs) agg exps fieldType - -val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {Type} -> nm :: Name - -> sql_exp tabs agg ([nm = t] ++ rest) t - -class sql_injectable -val sql_bool : sql_injectable bool -val sql_int : sql_injectable int -val sql_float : sql_injectable float -val sql_string : sql_injectable string -val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type - -> sql_injectable t -> t -> sql_exp tables agg exps t - -con sql_unary :: Type -> Type -> Type -val sql_not : sql_unary bool bool -val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> arg ::: Type -> res ::: Type - -> sql_unary arg res -> sql_exp tables agg exps arg -> sql_exp tables agg exps res - -con sql_binary :: Type -> Type -> Type -> Type -val sql_and : sql_binary bool bool bool -val sql_or : sql_binary bool bool bool -val sql_binary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} - -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type - -> sql_binary arg1 arg2 res -> sql_exp tables agg exps arg1 -> sql_exp tables agg exps arg2 - -> sql_exp tables agg exps res - -type sql_comparison -val sql_eq : sql_comparison -val sql_ne : sql_comparison -val sql_lt : sql_comparison -val sql_le : sql_comparison -val sql_gt : sql_comparison -val sql_ge : sql_comparison -val sql_comparison : sql_comparison - -> tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} - -> t ::: Type - -> sql_exp tables agg exps t -> sql_exp tables agg exps t - -> sql_exp tables agg exps bool - -val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} - -> unit -> sql_exp tables agg exps int - -con sql_aggregate :: Type -> Type -val sql_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type - -> sql_aggregate t -> sql_exp agg agg exps t -> sql_exp tables agg exps t - -class sql_summable -val sql_summable_int : sql_summable int -val sql_summable_float : sql_summable float -val sql_avg : t ::: Type -> sql_summable t -> sql_aggregate t -val sql_sum : t ::: Type -> sql_summable t -> sql_aggregate t - -class sql_maxable -val sql_maxable_int : sql_maxable int -val sql_maxable_float : sql_maxable float -val sql_maxable_string : sql_maxable string -val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t -val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t - - -(*** Executing queries *) - -con transaction :: Type -> Type -val return : t ::: Type - -> t -> transaction t -val bind : t1 ::: Type -> t2 ::: Type - -> transaction t1 -> (t1 -> transaction t2) - -> transaction t2 - -val query : tables ::: {{Type}} -> exps ::: {Type} - -> sql_query tables exps - -> state ::: Type - -> ($(fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables) - -> $exps - -> state - -> transaction state) - -> state - -> transaction state - - -(** XML *) - -con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type - - -con xml :: {Unit} -> {Type} -> {Type} -> Type -val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] -val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> attrsGiven ~ attrsAbsent - -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit} - -> useOuter ::: {Type} -> useInner ::: {Type} -> useOuter ~ useInner - -> bindOuter ::: {Type} -> bindInner ::: {Type} -> bindOuter ~ bindInner - -> $attrsGiven - -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter - -> xml ctxInner useInner bindInner - -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) -val join : ctx ::: {Unit} - -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} - -> use1 ~ bind1 -> bind1 ~ bind2 - -> xml ctx use1 bind1 - -> xml ctx (use1 ++ bind1) bind2 - -> xml ctx use1 (bind1 ++ bind2) -val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type} -> bind ::: {Type} - -> use1 ~ use2 - -> xml ctx use1 bind - -> xml ctx (use1 ++ use2) bind - -con xhtml = xml [Html] -con page = xhtml [] [] - -(*** HTML details *) - -con html = [Html] -con head = [Head] -con body = [Body] -con lform = [Body, LForm] - -val head : unit -> tag [] html head [] [] -val title : unit -> tag [] head [] [] [] - -val body : unit -> tag [] html body [] [] -con bodyTag = fn attrs :: {Type} => ctx ::: {Unit} -> [Body] ~ ctx -> unit - -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] -con bodyTagStandalone = fn attrs :: {Type} => ctx ::: {Unit} -> [Body] ~ ctx -> unit - -> tag attrs ([Body] ++ ctx) [] [] [] - -val br : bodyTagStandalone [] - -val p : bodyTag [] -val b : bodyTag [] -val i : bodyTag [] -val font : bodyTag [Size = int, Face = string] - -val h1 : bodyTag [] -val li : bodyTag [] - -val a : bodyTag [Link = page] - -val lform : ctx ::: {Unit} -> [Body] ~ ctx -> bind ::: {Type} - -> xml lform [] bind - -> xml ([Body] ++ ctx) [] [] -con lformTag = fn ty :: Type => fn inner :: {Unit} => fn attrs :: {Type} => - ctx ::: {Unit} -> [LForm] ~ ctx - -> nm :: Name -> unit - -> tag attrs ([LForm] ++ ctx) inner [] [nm = ty] -val textbox : lformTag string [] [] -val password : lformTag string [] [] -val ltextarea : lformTag string [] [] - -val checkbox : lformTag bool [] [] - -con radio = [Body, Radio] -val radio : lformTag string radio [] -val radioOption : unit -> tag [Value = string] radio [] [] [] - -con select = [Select] -val lselect : lformTag string select [] -val loption : unit -> tag [Value = string] select [] [] [] - -val submit : ctx ::: {Unit} -> [LForm] ~ ctx - -> use ::: {Type} -> unit - -> tag [Action = $use -> page] ([LForm] ++ ctx) ([LForm] ++ ctx) use [] diff -r 2b9dfaffb008 -r 71bafe66dbe1 lib/basis.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/basis.urs Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,249 @@ +type int +type float +type string + +type unit = {} + +datatype bool = False | True + + +(** SQL *) + +con sql_table :: {Type} -> Type + +(*** Queries *) + +con sql_query :: {{Type}} -> {Type} -> Type +con sql_query1 :: {{Type}} -> {{Type}} -> {Type} -> Type +con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type + +con sql_subset :: {{Type}} -> {{Type}} -> Type +val sql_subset : keep_drop :: {({Type} * {Type})} + -> sql_subset + (fold (fn nm => fn fields :: ({Type} * {Type}) => fn acc => + [nm] ~ acc => fields.1 ~ fields.2 => + [nm = fields.1 ++ fields.2] ++ acc) [] keep_drop) + (fold (fn nm => fn fields :: ({Type} * {Type}) => fn acc => + [nm] ~ acc => + [nm = fields.1] ++ acc) [] keep_drop) +val sql_subset_all : tables :: {{Type}} + -> sql_subset tables tables + +val sql_query1 : tables ::: {{Type}} + -> grouped ::: {{Type}} + -> selectedFields ::: {{Type}} + -> selectedExps ::: {Type} + -> {From : $(fold (fn nm => fn fields :: {Type} => fn acc => + [nm] ~ acc => [nm = sql_table fields] ++ acc) [] tables), + Where : sql_exp tables [] [] bool, + GroupBy : sql_subset tables grouped, + Having : sql_exp grouped tables [] bool, + SelectFields : sql_subset grouped selectedFields, + SelectExps : $(fold (fn nm => fn t :: Type => fn acc => + [nm] ~ acc => [nm = sql_exp grouped tables [] t] ++ acc) [] selectedExps) } + -> sql_query1 tables selectedFields selectedExps + +type sql_relop +val sql_union : sql_relop +val sql_intersect : sql_relop +val sql_except : sql_relop +val sql_relop : sql_relop + -> tables1 ::: {{Type}} + -> tables2 ::: {{Type}} + -> selectedFields ::: {{Type}} + -> selectedExps ::: {Type} + -> sql_query1 tables1 selectedFields selectedExps + -> sql_query1 tables2 selectedFields selectedExps + -> sql_query1 selectedFields selectedFields selectedExps + +type sql_direction +val sql_asc : sql_direction +val sql_desc : sql_direction + +con sql_order_by :: {{Type}} -> {Type} -> Type +val sql_order_by_Nil : tables ::: {{Type}} -> exps :: {Type} -> sql_order_by tables exps +val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type + -> sql_exp tables [] exps t -> sql_order_by tables exps + -> sql_order_by tables exps + +type sql_limit +val sql_no_limit : sql_limit +val sql_limit : int -> sql_limit + +type sql_offset +val sql_no_offset : sql_offset +val sql_offset : int -> sql_offset + +val sql_query : tables ::: {{Type}} + -> selectedFields ::: {{Type}} + -> selectedExps ::: {Type} + -> {Rows : sql_query1 tables selectedFields selectedExps, + OrderBy : sql_order_by tables selectedExps, + Limit : sql_limit, + Offset : sql_offset} + -> sql_query selectedFields selectedExps + +val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type} -> fieldType ::: Type -> agg ::: {{Type}} + -> exps ::: {Type} + -> tab :: Name -> field :: Name + -> sql_exp ([tab = [field = fieldType] ++ otherFields] ++ otherTabs) agg exps fieldType + +val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {Type} -> nm :: Name + -> sql_exp tabs agg ([nm = t] ++ rest) t + +class sql_injectable +val sql_bool : sql_injectable bool +val sql_int : sql_injectable int +val sql_float : sql_injectable float +val sql_string : sql_injectable string +val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type + -> sql_injectable t -> t -> sql_exp tables agg exps t + +con sql_unary :: Type -> Type -> Type +val sql_not : sql_unary bool bool +val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> arg ::: Type -> res ::: Type + -> sql_unary arg res -> sql_exp tables agg exps arg -> sql_exp tables agg exps res + +con sql_binary :: Type -> Type -> Type -> Type +val sql_and : sql_binary bool bool bool +val sql_or : sql_binary bool bool bool +val sql_binary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type + -> sql_binary arg1 arg2 res -> sql_exp tables agg exps arg1 -> sql_exp tables agg exps arg2 + -> sql_exp tables agg exps res + +type sql_comparison +val sql_eq : sql_comparison +val sql_ne : sql_comparison +val sql_lt : sql_comparison +val sql_le : sql_comparison +val sql_gt : sql_comparison +val sql_ge : sql_comparison +val sql_comparison : sql_comparison + -> tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type + -> sql_exp tables agg exps t -> sql_exp tables agg exps t + -> sql_exp tables agg exps bool + +val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> unit -> sql_exp tables agg exps int + +con sql_aggregate :: Type -> Type +val sql_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type + -> sql_aggregate t -> sql_exp agg agg exps t -> sql_exp tables agg exps t + +class sql_summable +val sql_summable_int : sql_summable int +val sql_summable_float : sql_summable float +val sql_avg : t ::: Type -> sql_summable t -> sql_aggregate t +val sql_sum : t ::: Type -> sql_summable t -> sql_aggregate t + +class sql_maxable +val sql_maxable_int : sql_maxable int +val sql_maxable_float : sql_maxable float +val sql_maxable_string : sql_maxable string +val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t +val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t + + +(*** Executing queries *) + +con transaction :: Type -> Type +val return : t ::: Type + -> t -> transaction t +val bind : t1 ::: Type -> t2 ::: Type + -> transaction t1 -> (t1 -> transaction t2) + -> transaction t2 + +val query : tables ::: {{Type}} -> exps ::: {Type} + -> sql_query tables exps + -> state ::: Type + -> ($(fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables) + -> $exps + -> state + -> transaction state) + -> state + -> transaction state + + +(** XML *) + +con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type + + +con xml :: {Unit} -> {Type} -> {Type} -> Type +val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] +val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> attrsGiven ~ attrsAbsent + -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit} + -> useOuter ::: {Type} -> useInner ::: {Type} -> useOuter ~ useInner + -> bindOuter ::: {Type} -> bindInner ::: {Type} -> bindOuter ~ bindInner + -> $attrsGiven + -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter + -> xml ctxInner useInner bindInner + -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) +val join : ctx ::: {Unit} + -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} + -> use1 ~ bind1 -> bind1 ~ bind2 + -> xml ctx use1 bind1 + -> xml ctx (use1 ++ bind1) bind2 + -> xml ctx use1 (bind1 ++ bind2) +val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type} -> bind ::: {Type} + -> use1 ~ use2 + -> xml ctx use1 bind + -> xml ctx (use1 ++ use2) bind + +con xhtml = xml [Html] +con page = xhtml [] [] + +(*** HTML details *) + +con html = [Html] +con head = [Head] +con body = [Body] +con lform = [Body, LForm] + +val head : unit -> tag [] html head [] [] +val title : unit -> tag [] head [] [] [] + +val body : unit -> tag [] html body [] [] +con bodyTag = fn attrs :: {Type} => ctx ::: {Unit} -> [Body] ~ ctx -> unit + -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] +con bodyTagStandalone = fn attrs :: {Type} => ctx ::: {Unit} -> [Body] ~ ctx -> unit + -> tag attrs ([Body] ++ ctx) [] [] [] + +val br : bodyTagStandalone [] + +val p : bodyTag [] +val b : bodyTag [] +val i : bodyTag [] +val font : bodyTag [Size = int, Face = string] + +val h1 : bodyTag [] +val li : bodyTag [] + +val a : bodyTag [Link = page] + +val lform : ctx ::: {Unit} -> [Body] ~ ctx -> bind ::: {Type} + -> xml lform [] bind + -> xml ([Body] ++ ctx) [] [] +con lformTag = fn ty :: Type => fn inner :: {Unit} => fn attrs :: {Type} => + ctx ::: {Unit} -> [LForm] ~ ctx + -> nm :: Name -> unit + -> tag attrs ([LForm] ++ ctx) inner [] [nm = ty] +val textbox : lformTag string [] [] +val password : lformTag string [] [] +val ltextarea : lformTag string [] [] + +val checkbox : lformTag bool [] [] + +con radio = [Body, Radio] +val radio : lformTag string radio [] +val radioOption : unit -> tag [Value = string] radio [] [] [] + +con select = [Select] +val lselect : lformTag string select [] +val loption : unit -> tag [Value = string] select [] [] [] + +val submit : ctx ::: {Unit} -> [LForm] ~ ctx + -> use ::: {Type} -> unit + -> tag [Action = $use -> page] ([LForm] ++ ctx) ([LForm] ++ ctx) use [] diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/c/driver.c --- a/src/c/driver.c Thu Aug 28 14:48:33 2008 -0400 +++ b/src/c/driver.c Sun Aug 31 08:32:18 2008 -0400 @@ -7,7 +7,7 @@ #include -#include "lacweb.h" +#include "urweb.h" int lw_port = 8080; int lw_backlog = 10; diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/cjr_print.sig --- a/src/cjr_print.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/cjr_print.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web C jr. language *) +(* Pretty-printing Ur/Web C jr. language *) signature CJR_PRINT = sig val p_typ : CjrEnv.env -> Cjr.typ Print.printer diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/cjr_print.sml --- a/src/cjr_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/cjr_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -1145,7 +1145,7 @@ string "#include ", newline, newline, - string "#include \"lacweb.h\"", + string "#include \"urweb.h\"", newline, newline, p_list_sep newline (fn x => x) pds, diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/compiler.sig --- a/src/compiler.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/compiler.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Laconic/Web main compiler interface *) +(* Ur/Web main compiler interface *) signature COMPILER = sig @@ -44,8 +44,8 @@ val time : ('src, 'dst) transform -> 'src -> unit val timePrint : ('src, 'dst) transform -> 'src -> unit - val parseLac : (string, Source.file) phase - val parseLig : (string, Source.sgn_item list) phase + val parseUr : (string, Source.file) phase + val parseUrs : (string, Source.sgn_item list) phase val parse : (job, Source.file) phase val elaborate : (Source.file, Elab.file) phase diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/compiler.sml --- a/src/compiler.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/compiler.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,13 +25,13 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Laconic/Web language parser *) +(* Ur/Web language parser *) structure Compiler :> COMPILER = struct -structure LacwebLrVals = LacwebLrValsFn(structure Token = LrParser.Token) -structure Lex = LacwebLexFn(structure Tokens = LacwebLrVals.Tokens) -structure LacwebP = Join(structure ParserData = LacwebLrVals.ParserData +structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) +structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) +structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData structure Lex = Lex structure LrParser = LrParser) @@ -123,7 +123,7 @@ print "\n") end -val parseLig = +val parseUrs = {func = fn filename => let val fname = OS.FileSys.tmpName () val outf = TextIO.openOut fname @@ -145,7 +145,7 @@ fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) - val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ()) + val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) in TextIO.closeIn file; case absyn of @@ -161,7 +161,7 @@ print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item} (* The main parsing routine *) -val parseLac = { +val parseUr = { func = fn filename => let val () = (ErrorMsg.resetErrors (); @@ -171,7 +171,7 @@ fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) - val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ()) + val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) in TextIO.closeIn file; case absyn of @@ -198,23 +198,23 @@ fun parseOne fname = let val mname = nameOf fname - val lac = OS.Path.joinBaseExt {base = fname, ext = SOME "lac"} - val lig = OS.Path.joinBaseExt {base = fname, ext = SOME "lig"} + val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"} + val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} val sgnO = - if Posix.FileSys.access (lig, []) then - SOME (Source.SgnConst (#func parseLig lig), - {file = lig, + if Posix.FileSys.access (urs, []) then + SOME (Source.SgnConst (#func parseUrs urs), + {file = urs, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) else NONE - val loc = {file = lac, + val loc = {file = ur, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} - val ds = #func parseLac lac + val ds = #func parseUr ur in (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) end @@ -234,7 +234,7 @@ val elaborate = { func = fn file => let - val basis = #func parseLig "lib/basis.lig" + val basis = #func parseUrs "lib/basis.urs" in Elaborate.elabFile basis ElabEnv.empty file end, @@ -334,7 +334,7 @@ fun compileC {cname, oname, ename} = let val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname - val link = "gcc -pthread -O3 clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename + val link = "gcc -pthread -O3 clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -346,11 +346,11 @@ fun compile job = case run toCjrize job of - NONE => print "Laconic compilation failed\n" + NONE => print "Ur compilation failed\n" | SOME file => let - val cname = "/tmp/lacweb.c" - val oname = "/tmp/lacweb.o" + val cname = "/tmp/urweb.c" + val oname = "/tmp/urweb.o" val ename = "/tmp/webapp" val outf = TextIO.openOut cname diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/core_print.sig --- a/src/core_print.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/core_print.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web internal language *) +(* Pretty-printing Ur/Web internal language *) signature CORE_PRINT = sig val p_kind : Core.kind Print.printer diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/core_print.sml --- a/src/core_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/core_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing core Laconic/Web *) +(* Pretty-printing core Ur/Web *) structure CorePrint :> CORE_PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/elab_print.sig --- a/src/elab_print.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/elab_print.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web *) +(* Pretty-printing Ur/Web *) signature ELAB_PRINT = sig val p_kind : Elab.kind Print.printer diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/elab_print.sml --- a/src/elab_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/elab_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing elaborated Laconic/Web *) +(* Pretty-printing elaborated Ur/Web *) structure ElabPrint :> ELAB_PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/expl_print.sml --- a/src/expl_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/expl_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing elaborated Laconic/Web *) +(* Pretty-printing elaborated Ur/Web *) structure ExplPrint :> EXPL_PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/lacweb.grm --- a/src/lacweb.grm Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1055 +0,0 @@ -(* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) - -(* Grammar for Laconic/Web programs *) - -open Source - -val s = ErrorMsg.spanOf -val dummy = ErrorMsg.dummySpan - -fun capitalize "" = "" - | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) - -fun entable t = - case #1 t of - TRecord c => c - | _ => t - -datatype select_item = - Field of con * con - | Exp of con * exp - -datatype select = - Star - | Items of select_item list - -datatype group_item = - GField of con * con - -fun eqTnames ((c1, _), (c2, _)) = - case (c1, c2) of - (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 - | (CName x1, CName x2) => x1 = x2 - | _ => false - -fun amend_select loc (si, (tabs, exps)) = - case si of - Field (tx, fx) => - let - val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc) - - val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => - if eqTnames (tx, tx') then - ((tx', (CConcat (c, c'), loc)), true) - else - ((tx', c'), found)) - false tabs - in - if found then - () - else - ErrorMsg.errorAt loc "Select of field from unbound table"; - - (tabs, exps) - end - | Exp (c, e) => (tabs, (c, e) :: exps) - -fun amend_group loc (gi, tabs) = - let - val (tx, c) = case gi of - GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) - - val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => - if eqTnames (tx, tx') then - ((tx', (CConcat (c, c'), loc)), true) - else - ((tx', c'), found)) - false tabs - in - if found then - () - else - ErrorMsg.errorAt loc "Select of field from unbound table"; - - tabs - end - -fun sql_inject (v, t, loc) = - let - val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (t, loc)), loc) - in - (EApp (e, (v, loc)), loc) - end - -fun sql_compare (oper, sqlexp1, sqlexp2, loc) = - let - val e = (EVar (["Basis"], "sql_comparison"), loc) - val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) - val e = (EApp (e, sqlexp1), loc) - in - (EApp (e, sqlexp2), loc) - end - -fun sql_binary (oper, sqlexp1, sqlexp2, loc) = - let - val e = (EVar (["Basis"], "sql_binary"), loc) - val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) - val e = (EApp (e, sqlexp1), loc) - in - (EApp (e, sqlexp2), loc) - end - -fun sql_unary (oper, sqlexp, loc) = - let - val e = (EVar (["Basis"], "sql_unary"), loc) - val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) - in - (EApp (e, sqlexp), loc) - end - -fun sql_relop (oper, sqlexp1, sqlexp2, loc) = - let - val e = (EVar (["Basis"], "sql_relop"), loc) - val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) - val e = (EApp (e, sqlexp1), loc) - in - (EApp (e, sqlexp2), loc) - end - -%% -%header (functor LacwebLrValsFn(structure Token : TOKEN)) - -%term - EOF - | STRING of string | INT of Int64.int | FLOAT of Real64.real - | SYMBOL of string | CSYMBOL of string - | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE - | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR - | DIVIDE | DOTDOTDOT - | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS - | DATATYPE | OF - | TYPE | NAME - | ARROW | LARROW | DARROW | STAR | SEMI - | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE - | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE - | CASE | IF | THEN | ELSE - - | XML_BEGIN of string | XML_END - | NOTAGS of string - | BEGIN_TAG of string | END_TAG of string - - | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING - | UNION | INTERSECT | EXCEPT - | LIMIT | OFFSET | ALL - | TRUE | FALSE | CAND | OR | NOT - | COUNT | AVG | SUM | MIN | MAX - | NE | LT | LE | GT | GE - -%nonterm - file of decl list - | decls of decl list - | decl of decl - | vali of string * con option * exp - | valis of (string * con option * exp) list - | copt of con option - - | dargs of string list - | barOpt of unit - | dcons of (string * con option) list - | dcon of string * con option - - | sgn of sgn - | sgntm of sgn - | sgi of sgn_item - | sgis of sgn_item list - - | str of str - - | kind of kind - | ktuple of kind list - | kcolon of explicitness - | kopt of kind option - - | path of string list * string - | cpath of string list * string - | spath of str - | mpath of string list - - | cexp of con - | capps of con - | cterm of con - | ctuple of con list - | ctuplev of con list - | ident of con - | idents of con list - | rcon of (con * con) list - | rconn of (con * con) list - | rcone of (con * con) list - | cargs of con * kind -> con * kind - | cargl of con * kind -> con * kind - | cargl2 of con * kind -> con * kind - | carg of con * kind -> con * kind - | cargp of con * kind -> con * kind - - | eexp of exp - | eapps of exp - | eterm of exp - | etuple of exp list - | rexp of (con * exp) list - | xml of exp - | xmlOne of exp - | tag of string * exp - | tagHead of string * exp - - | earg of exp * con -> exp * con - | eargp of exp * con -> exp * con - | eargs of exp * con -> exp * con - | eargl of exp * con -> exp * con - | eargl2 of exp * con -> exp * con - - | branch of pat * exp - | branchs of (pat * exp) list - | pat of pat - | pterm of pat - | rpat of (string * pat) list * bool - | ptuple of pat list - - | attrs of (con * exp) list - | attr of con * exp - | attrv of exp - - | query of exp - | query1 of exp - | tables of (con * exp) list - | tname of con - | table of con * exp - | tident of con - | fident of con - | seli of select_item - | selis of select_item list - | select of select - | sqlexp of exp - | wopt of exp - | groupi of group_item - | groupis of group_item list - | gopt of group_item list option - | hopt of exp - | obopt of exp - | obexps of exp - | lopt of exp - | ofopt of exp - | sqlint of exp - | sqlagg of string - - -%verbose (* print summary of errors *) -%pos int (* positions *) -%start file -%pure -%eop EOF -%noshift EOF - -%name Lacweb - -%right SEMI -%nonassoc LARROW -%nonassoc IF THEN ELSE -%nonassoc DARROW -%nonassoc COLON -%nonassoc DCOLON TCOLON -%left UNION INTERSECT EXCEPT -%right COMMA -%right OR -%right CAND -%nonassoc EQ NE LT LE GT GE -%right ARROW -%right PLUSPLUS MINUSMINUS -%right STAR -%left NOT -%nonassoc TWIDDLE -%nonassoc DOLLAR -%left DOT -%nonassoc LBRACE RBRACE - -%% - -file : decls (decls) - | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), - s (SIGleft, sgisright))]) - -decls : ([]) - | decl decls (decl :: decls) - -decl : CON SYMBOL cargl2 kopt EQ cexp (let - val loc = s (CONleft, cexpright) - - val k = Option.getOpt (kopt, (KWild, loc)) - val (c, k) = cargl2 (cexp, k) - in - (DCon (SYMBOL, SOME k, c), loc) - end) - | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), - s (LTYPEleft, cexpright)) - | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) - | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path - (case dargs of - [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) - | _ => raise Fail "Arguments specified for imported datatype") - | VAL vali (DVal vali, s (VALleft, valiright)) - | VAL REC valis (DValRec valis, s (VALleft, valisright)) - | FUN valis (DValRec valis, s (FUNleft, valisright)) - - | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) - | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright)) - | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright)) - | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str - (DStr (CSYMBOL1, NONE, - (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), - s (FUNCTORleft, strright)) - | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str - (DStr (CSYMBOL1, NONE, - (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), - s (FUNCTORleft, strright)) - | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright)) - | OPEN mpath (case mpath of - [] => raise Fail "Impossible mpath parse [1]" - | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright))) - | OPEN CONSTRAINTS mpath (case mpath of - [] => raise Fail "Impossible mpath parse [3]" - | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) - | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) - | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) - | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright)) - | CLASS SYMBOL SYMBOL EQ cexp (let - val loc = s (CLASSleft, cexpright) - val k = (KType, loc) - val c = (CAbs (SYMBOL2, SOME k, cexp), loc) - in - (DClass (SYMBOL1, c), s (CLASSleft, cexpright)) - end) - -kopt : (NONE) - | DCOLON kind (SOME kind) - -dargs : ([]) - | SYMBOL dargs (SYMBOL :: dargs) - -barOpt : () - | BAR () - -dcons : dcon ([dcon]) - | dcon BAR dcons (dcon :: dcons) - -dcon : CSYMBOL (CSYMBOL, NONE) - | CSYMBOL OF cexp (CSYMBOL, SOME cexp) - -vali : SYMBOL eargl2 copt EQ eexp (let - val loc = s (SYMBOLleft, eexpright) - val t = Option.getOpt (copt, (CWild (KType, loc), loc)) - - val (e, t) = eargl2 (eexp, t) - in - (SYMBOL, SOME t, e) - end) - -copt : (NONE) - | COLON cexp (SOME cexp) - -valis : vali ([vali]) - | vali AND valis (vali :: valis) - -sgn : sgntm (sgntm) - | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn - (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right)) - -sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) - | mpath (case mpath of - [] => raise Fail "Impossible mpath parse [2]" - | [x] => SgnVar x - | m :: ms => SgnProj (m, - List.take (ms, length ms - 1), - List.nth (ms, length ms - 1)), - s (mpathleft, mpathright)) - | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) - | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) - | LPAREN sgn RPAREN (sgn) - -sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright)) - | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))), - s (LTYPEleft, SYMBOLright)) - | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)) - | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)) - | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), - s (LTYPEleft, cexpright)) - | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) - | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path - (case dargs of - [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) - | _ => raise Fail "Arguments specified for imported datatype") - | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright)) - - | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)) - | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) - | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn - (SgiStr (CSYMBOL1, - (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))), - s (FUNCTORleft, sgn2right)) - | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) - | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) - | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) - | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) - | CLASS SYMBOL SYMBOL EQ cexp (let - val loc = s (CLASSleft, cexpright) - val k = (KType, loc) - val c = (CAbs (SYMBOL2, SOME k, cexp), loc) - in - (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) - end) - -sgis : ([]) - | sgi sgis (sgi :: sgis) - -str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright)) - | spath (spath) - | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str - (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright)) - | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str - (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)) - | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright)) - -spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) - | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright)) - -kind : TYPE (KType, s (TYPEleft, TYPEright)) - | NAME (KName, s (NAMEleft, NAMEright)) - | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) - | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) - | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) - | KUNIT (KUnit, s (KUNITleft, KUNITright)) - | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) - | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) - -ktuple : kind STAR kind ([kind1, kind2]) - | kind STAR ktuple (kind :: ktuple) - -capps : cterm (cterm) - | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) - -cexp : capps (capps) - | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) - | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) - - | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) - - | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) - | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) - | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) - - | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) - - | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright)) - | ctuple (let - val loc = s (ctupleleft, ctupleright) - in - (TRecord (CRecord (ListUtil.mapi (fn (i, c) => - ((CName (Int.toString (i + 1)), loc), - c)) ctuple), - loc), loc) - end) - -kcolon : DCOLON (Explicit) - | TCOLON (Implicit) - -cargs : carg (carg) - | cargl (cargl) - -cargl : cargp cargp (cargp1 o cargp2) - | cargp cargl (cargp o cargl) - -cargl2 : (fn x => x) - | cargp cargl2 (cargp o cargl2) - -carg : SYMBOL DCOLON kind (fn (c, k) => - let - val loc = s (SYMBOLleft, kindright) - in - ((CAbs (SYMBOL, SOME kind, c), loc), - (KArrow (kind, k), loc)) - end) - | cargp (cargp) - -cargp : SYMBOL (fn (c, k) => - let - val loc = s (SYMBOLleft, SYMBOLright) - in - ((CAbs (SYMBOL, NONE, c), loc), - (KArrow ((KWild, loc), k), loc)) - end) - | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) => - let - val loc = s (LPARENleft, RPARENright) - in - ((CAbs (SYMBOL, SOME kind, c), loc), - (KArrow (kind, k), loc)) - end) - -path : SYMBOL ([], SYMBOL) - | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end) - -cpath : CSYMBOL ([], CSYMBOL) - | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end) - -mpath : CSYMBOL ([CSYMBOL]) - | CSYMBOL DOT mpath (CSYMBOL :: mpath) - -cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) - | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) - | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright)) - | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), - s (LBRACEleft, RBRACEright)) - | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) - | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) - | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright)) - - | path (CVar path, s (pathleft, pathright)) - | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT), - s (pathleft, INTright)) - | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright)) - | FOLD (CFold, s (FOLDleft, FOLDright)) - | UNIT (CUnit, s (UNITleft, UNITright)) - | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright)) - -ctuplev: cexp COMMA cexp ([cexp1, cexp2]) - | cexp COMMA ctuplev (cexp :: ctuplev) - -ctuple : capps STAR capps ([capps1, capps2]) - | capps STAR ctuple (capps :: ctuple) - -rcon : ([]) - | ident EQ cexp ([(ident, cexp)]) - | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon) - -rconn : ident ([(ident, (CUnit, s (identleft, identright)))]) - | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn) - -rcone : ([]) - | ident COLON cexp ([(ident, cexp)]) - | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone) - -ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) - | INT (CName (Int64.toString INT), s (INTleft, INTright)) - | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)) - -eapps : eterm (eterm) - | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) - | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) - -eexp : eapps (eapps) - | FN eargs DARROW eexp (let - val loc = s (FNleft, eexpright) - in - #1 (eargs (eexp, (CWild (KType, loc), loc))) - end) - | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright)) - | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) - | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) - | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) - | IF eexp THEN eexp ELSE eexp (let - val loc = s (IFleft, eexp3right) - in - (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), - ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) - end) - | SYMBOL LARROW eexp SEMI eexp (let - val loc = s (SYMBOLleft, eexp2right) - val e = (EVar (["Basis"], "bind"), loc) - val e = (EApp (e, eexp1), loc) - in - (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc) - end) - -eargs : earg (earg) - | eargl (eargl) - -eargl : eargp eargp (eargp1 o eargp2) - | eargp eargl (eargp o eargl) - -eargl2 : (fn x => x) - | eargp eargl2 (eargp o eargl2) - -earg : SYMBOL kcolon kind (fn (e, t) => - let - val loc = s (SYMBOLleft, kindright) - in - ((ECAbs (kcolon, SYMBOL, kind, e), loc), - (TCFun (kcolon, SYMBOL, kind, t), loc)) - end) - | SYMBOL COLON cexp (fn (e, t) => - let - val loc = s (SYMBOLleft, cexpright) - in - ((EAbs (SYMBOL, SOME cexp, e), loc), - (TFun (cexp, t), loc)) - end) - | UNDER COLON cexp (fn (e, t) => - let - val loc = s (UNDERleft, cexpright) - in - ((EAbs ("_", SOME cexp, e), loc), - (TFun (cexp, t), loc)) - end) - | eargp (eargp) - -eargp : SYMBOL (fn (e, t) => - let - val loc = s (SYMBOLleft, SYMBOLright) - in - ((EAbs (SYMBOL, NONE, e), loc), - (TFun ((CWild (KType, loc), loc), t), loc)) - end) - | UNIT (fn (e, t) => - let - val loc = s (UNITleft, UNITright) - val t' = (TRecord (CRecord [], loc), loc) - in - ((EAbs ("_", SOME t', e), loc), - (TFun (t', t), loc)) - end) - | UNDER (fn (e, t) => - let - val loc = s (UNDERleft, UNDERright) - in - ((EAbs ("_", NONE, e), loc), - (TFun ((CWild (KType, loc), loc), t), loc)) - end) - | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) => - let - val loc = s (LPARENleft, RPARENright) - in - ((ECAbs (kcolon, SYMBOL, kind, e), loc), - (TCFun (kcolon, SYMBOL, kind, t), loc)) - end) - | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) => - let - val loc = s (LPARENleft, RPARENright) - in - ((EAbs (SYMBOL, SOME cexp, e), loc), - (TFun (cexp, t), loc)) - end) - | LPAREN UNDER COLON cexp RPAREN (fn (e, t) => - let - val loc = s (LPARENleft, RPARENright) - in - ((EAbs ("_", SOME cexp, e), loc), - (TFun (cexp, t), loc)) - end) - -eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) - | LPAREN etuple RPAREN (let - val loc = s (LPARENleft, RPARENright) - in - (ERecord (ListUtil.mapi (fn (i, e) => - ((CName (Int.toString (i + 1)), loc), - e)) etuple), loc) - end) - - | path (EVar path, s (pathleft, pathright)) - | cpath (EVar cpath, s (cpathleft, cpathright)) - | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) - | UNIT (ERecord [], s (UNITleft, UNITright)) - - | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) - | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) - | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) - - | path DOT idents (let - val loc = s (pathleft, identsright) - in - foldl (fn (ident, e) => - (EField (e, ident), loc)) - (EVar path, s (pathleft, pathright)) idents - end) - | FOLD (EFold, s (FOLDleft, FOLDright)) - - | XML_BEGIN xml XML_END (xml) - | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)), - (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))), - s (XML_BEGINleft, XML_ENDright)) - | LPAREN query RPAREN (query) - | UNDER (EWild, s (UNDERleft, UNDERright)) - -idents : ident ([ident]) - | ident DOT idents (ident :: idents) - -etuple : eexp COMMA eexp ([eexp1, eexp2]) - | eexp COMMA etuple (eexp :: etuple) - -branch : pat DARROW eexp (pat, eexp) - -branchs: ([]) - | BAR branch branchs (branch :: branchs) - -pat : pterm (pterm) - | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright)) - -pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) - | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) - | UNDER (PWild, s (UNDERleft, UNDERright)) - | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) - | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) - | LPAREN pat RPAREN (pat) - | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) - | UNIT (PRecord ([], false), s (UNITleft, UNITright)) - | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) - | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple, - false), - s (LPARENleft, RPARENright)) - -rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) - | INT EQ pat ([(Int64.toString INT, pat)], false) - | DOTDOTDOT ([], true) - | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat) - | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat) - -ptuple : pat COMMA pat ([pat1, pat2]) - | pat COMMA ptuple (pat :: ptuple) - -rexp : ([]) - | ident EQ eexp ([(ident, eexp)]) - | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp) - -xml : xmlOne xml (let - val pos = s (xmlOneleft, xmlright) - in - (EApp ((EApp ( - (EVar (["Basis"], "join"), pos), - xmlOne), pos), - xml), pos) - end) - | xmlOne (xmlOne) - -xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)), - (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), - s (NOTAGSleft, NOTAGSright)) - | tag DIVIDE GT (let - val pos = s (tagleft, GTright) - in - (EApp (#2 tag, - (EApp ((EVar (["Basis"], "cdata"), pos), - (EPrim (Prim.String ""), pos)), - pos)), pos) - end) - - | tag GT xml END_TAG (let - val pos = s (tagleft, GTright) - in - if #1 tag = END_TAG then - if END_TAG = "lform" then - (EApp ((EVar (["Basis"], "lform"), pos), - xml), pos) - else - (EApp (#2 tag, xml), pos) - else - (ErrorMsg.errorAt pos "Begin and end tags don't match."; - (EFold, pos)) - end) - | LBRACE eexp RBRACE (eexp) - -tag : tagHead attrs (let - val pos = s (tagHeadleft, attrsright) - in - (#1 tagHead, - (EApp ((EApp ((EVar (["Basis"], "tag"), pos), - (ERecord attrs, pos)), pos), - (EApp (#2 tagHead, - (ERecord [], pos)), pos)), - pos)) - end) - -tagHead: BEGIN_TAG (let - val pos = s (BEGIN_TAGleft, BEGIN_TAGright) - in - (BEGIN_TAG, - (EVar ([], BEGIN_TAG), pos)) - end) - | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) - -attrs : ([]) - | attr attrs (attr :: attrs) - -attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv) - -attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) - | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) - | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) - | LBRACE eexp RBRACE (eexp) - -query : query1 obopt lopt ofopt (let - val loc = s (query1left, query1right) - - val re = (ERecord [((CName "Rows", loc), - query1), - ((CName "OrderBy", loc), - obopt), - ((CName "Limit", loc), - lopt), - ((CName "Offset", loc), - ofopt)], loc) - in - (EApp ((EVar (["Basis"], "sql_query"), loc), re), loc) - end) - -query1 : SELECT select FROM tables wopt gopt hopt - (let - val loc = s (SELECTleft, tablesright) - - val (sel, exps) = - case select of - Star => (map (fn (nm, _) => - (nm, (CTuple [(CWild (KRecord (KType, loc), loc), - loc), - (CRecord [], loc)], - loc))) tables, - []) - | Items sis => - let - val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables - val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis - in - (map (fn (nm, c) => (nm, - (CTuple [c, - (CWild (KRecord (KType, loc), loc), - loc)], loc))) tabs, - exps) - end - - val sel = (CRecord sel, loc) - - val grp = case gopt of - NONE => (ECApp ((EVar (["Basis"], "sql_subset_all"), loc), - (CWild (KRecord (KRecord (KType, loc), loc), - loc), loc)), loc) - | SOME gis => - let - val tabs = map (fn (nm, _) => - (nm, (CRecord [], loc))) tables - val tabs = foldl (amend_group loc) tabs gis - - val tabs = map (fn (nm, c) => - (nm, - (CTuple [c, - (CWild (KRecord (KType, loc), - loc), - loc)], loc))) tabs - in - (ECApp ((EVar (["Basis"], "sql_subset"), loc), - (CRecord tabs, loc)), loc) - end - - val e = (EVar (["Basis"], "sql_query1"), loc) - val re = (ERecord [((CName "From", loc), - (ERecord tables, loc)), - ((CName "Where", loc), - wopt), - ((CName "GroupBy", loc), - grp), - ((CName "Having", loc), - hopt), - ((CName "SelectFields", loc), - (ECApp ((EVar (["Basis"], "sql_subset"), loc), - sel), loc)), - ((CName "SelectExps", loc), - (ERecord exps, loc))], loc) - - val e = (EApp (e, re), loc) - in - e - end) - | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right))) - | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right))) - | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right))) - -tables : table ([table]) - | table COMMA tables (table :: tables) - -tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) - | LBRACE cexp RBRACE (cexp) - -table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), - (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) - | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) - | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp) - -tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)) - | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) - | LBRACE LBRACE cexp RBRACE RBRACE (cexp) - -fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) - | LBRACE cexp RBRACE (cexp) - -seli : tident DOT fident (Field (tident, fident)) - | sqlexp AS fident (Exp (fident, sqlexp)) - -selis : seli ([seli]) - | seli COMMA selis (seli :: selis) - -select : STAR (Star) - | selis (Items selis) - -sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"), - EVar (["Basis"], "sql_bool"), - s (TRUEleft, TRUEright))) - | FALSE (sql_inject (EVar (["Basis"], "False"), - EVar (["Basis"], "sql_bool"), - s (FALSEleft, FALSEright))) - - | INT (sql_inject (EPrim (Prim.Int INT), - EVar (["Basis"], "sql_int"), - s (INTleft, INTright))) - | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), - EVar (["Basis"], "sql_float"), - s (FLOATleft, FLOATright))) - | STRING (sql_inject (EPrim (Prim.String STRING), - EVar (["Basis"], "sql_string"), - s (STRINGleft, STRINGright))) - - | tident DOT fident (let - val loc = s (tidentleft, fidentright) - val e = (EVar (["Basis"], "sql_field"), loc) - val e = (ECApp (e, tident), loc) - in - (ECApp (e, fident), loc) - end) - | CSYMBOL (let - val loc = s (CSYMBOLleft, CSYMBOLright) - val e = (EVar (["Basis"], "sql_exp"), loc) - in - (ECApp (e, (CName CSYMBOL, loc)), loc) - end) - - | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - - | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) - - | LBRACE eexp RBRACE (sql_inject (#1 eexp, - EWild, - s (LBRACEleft, RBRACEright))) - | LPAREN sqlexp RPAREN (sqlexp) - - | COUNT LPAREN STAR RPAREN (let - val loc = s (COUNTleft, RPARENright) - in - (EApp ((EVar (["Basis"], "sql_count"), loc), - (ERecord [], loc)), loc) - end) - | sqlagg LPAREN sqlexp RPAREN (let - val loc = s (sqlaggleft, RPARENright) - - val e = (EApp ((EVar (["Basis"], "sql_" ^ sqlagg), loc), - (EWild, loc)), loc) - val e = (EApp ((EVar (["Basis"], "sql_aggregate"), loc), - e), loc) - in - (EApp (e, sqlexp), loc) - end) - -wopt : (sql_inject (EVar (["Basis"], "True"), - EVar (["Basis"], "sql_bool"), - dummy)) - | CWHERE sqlexp (sqlexp) - -groupi : tident DOT fident (GField (tident, fident)) - -groupis: groupi ([groupi]) - | groupi COMMA groupis (groupi :: groupis) - -gopt : (NONE) - | GROUP BY groupis (SOME groupis) - -hopt : (sql_inject (EVar (["Basis"], "True"), - EVar (["Basis"], "sql_bool"), - dummy)) - | HAVING sqlexp (sqlexp) - -obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), dummy), - (CWild (KRecord (KType, dummy), dummy), dummy)), - dummy) - | ORDER BY obexps (obexps) - -obexps : sqlexp (let - val loc = s (sqlexpleft, sqlexpright) - - val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc), - (CWild (KRecord (KType, loc), loc), loc)), - loc) - val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), - sqlexp), loc) - in - (EApp (e, e'), loc) - end) - | sqlexp COMMA obexps (let - val loc = s (sqlexpleft, obexpsright) - - val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), - sqlexp), loc) - in - (EApp (e, obexps), loc) - end) - -lopt : (EVar (["Basis"], "sql_no_limit"), dummy) - | LIMIT ALL (EVar (["Basis"], "sql_no_limit"), dummy) - | LIMIT sqlint (let - val loc = s (LIMITleft, sqlintright) - in - (EApp ((EVar (["Basis"], "sql_limit"), loc), sqlint), loc) - end) - -ofopt : (EVar (["Basis"], "sql_no_offset"), dummy) - | OFFSET sqlint (let - val loc = s (OFFSETleft, sqlintright) - in - (EApp ((EVar (["Basis"], "sql_offset"), loc), sqlint), loc) - end) - -sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) - | LBRACE eexp RBRACE (eexp) - -sqlagg : AVG ("avg") - | SUM ("sum") - | MIN ("min") - | MAX ("max") diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/lacweb.lex --- a/src/lacweb.lex Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,353 +0,0 @@ -(* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) - -(* Lexing info for Laconic/Web programs *) - -type pos = int -type svalue = Tokens.svalue -type ('a,'b) token = ('a,'b) Tokens.token -type lexresult = (svalue,pos) Tokens.token - -local - val commentLevel = ref 0 - val commentPos = ref 0 -in - fun enterComment pos = - (if !commentLevel = 0 then - commentPos := pos - else - (); - commentLevel := !commentLevel + 1) - - fun exitComment () = - (ignore (commentLevel := !commentLevel - 1); - !commentLevel = 0) - - fun eof () = - let - val pos = ErrorMsg.lastLineStart () - in - if !commentLevel > 0 then - ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" - else - (); - Tokens.EOF (pos, pos) - end -end - -val strEnder = ref #"\"" -val str = ref ([] : char list) -val strStart = ref 0 - -local - val initSig = ref false - val offset = ref 0 -in - -fun initialSig () = initSig := true - -fun pos yypos = yypos - !offset - -fun newline yypos = - if !initSig then - (initSig := false; - offset := yypos + 1) - else - ErrorMsg.newline (pos yypos) - -end - -val xmlTag = ref ([] : string list) -val xmlString = ref true -val braceLevels = ref ([] : ((unit -> unit) * int) list) - -fun pushLevel s = braceLevels := (s, 1) :: (!braceLevels) - -fun enterBrace () = - case !braceLevels of - (s, i) :: rest => braceLevels := (s, i+1) :: rest - | _ => () - -fun exitBrace () = - case !braceLevels of - (s, i) :: rest => - if i = 1 then - (braceLevels := rest; - s ()) - else - braceLevels := (s, i-1) :: rest - | _ => () - -fun initialize () = (xmlTag := []; - xmlString := false) - - -%% -%header (functor LacwebLexFn(structure Tokens : Lacweb_TOKENS)); -%full -%s COMMENT STRING XML XMLTAG; - -id = [a-z_][A-Za-z0-9_']*; -cid = [A-Z][A-Za-z0-9_']*; -ws = [\ \t\012]; -intconst = [0-9]+; -realconst = [0-9]+\.[0-9]*; -notags = [^<{\n]+; - -%% - - \n => (newline yypos; - continue ()); - \n => (newline yypos; - continue ()); - \n => (newline yypos; - continue ()); - \n => (newline yypos; - Tokens.NOTAGS (yytext, yypos, yypos + size yytext)); - - {ws}+ => (lex ()); - - "(*" => (YYBEGIN COMMENT; - enterComment (pos yypos); - continue ()); - "*)" => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments"; - continue ()); - - "(*" => (enterComment (pos yypos); - continue ()); - "*)" => (if exitComment () then YYBEGIN INITIAL else (); - continue ()); - - "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); - "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); - "\\\"" => (str := #"\"" :: !str; continue()); - "\\'" => (str := #"'" :: !str; continue()); - "\n" => (newline yypos; - str := #"\n" :: !str; continue()); - . => (let - val ch = String.sub (yytext, 0) - in - if ch = !strEnder then - (if !xmlString then - (xmlString := false; YYBEGIN XMLTAG) - else - YYBEGIN INITIAL; - Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1)) - else - (str := ch :: !str; - continue ()) - end); - - "<" {id} ">"=> (let - val tag = String.substring (yytext, 1, size yytext - 2) - in - YYBEGIN XML; - xmlTag := tag :: (!xmlTag); - Tokens.XML_BEGIN (tag, yypos, yypos + size yytext) - end); - "" => (let - val id = String.substring (yytext, 2, size yytext - 3) - in - case !xmlTag of - id' :: rest => - if id = id' then - (YYBEGIN INITIAL; - xmlTag := rest; - Tokens.XML_END (yypos, yypos + size yytext)) - else - Tokens.END_TAG (id, yypos, yypos + size yytext) - | _ => - Tokens.END_TAG (id, yypos, yypos + size yytext) - end); - - "<" {id} => (YYBEGIN XMLTAG; - Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE), - yypos, yypos + size yytext)); - - "/" => (Tokens.DIVIDE (yypos, yypos + size yytext)); - ">" => (YYBEGIN XML; - Tokens.GT (yypos, yypos + size yytext)); - - {ws}+ => (lex ()); - - {id} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); - "=" => (Tokens.EQ (yypos, yypos + size yytext)); - - {intconst} => (case Int64.fromString yytext of - SOME x => Tokens.INT (x, yypos, yypos + size yytext) - | NONE => (ErrorMsg.errorAt' (yypos, yypos) - ("Expected int, received: " ^ yytext); - continue ())); - {realconst} => (case Real.fromString yytext of - SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext) - | NONE => (ErrorMsg.errorAt' (yypos, yypos) - ("Expected float, received: " ^ yytext); - continue ())); - "\"" => (YYBEGIN STRING; - xmlString := true; - strStart := yypos; str := []; continue ()); - - "{" => (YYBEGIN INITIAL; - pushLevel (fn () => YYBEGIN XMLTAG); - Tokens.LBRACE (yypos, yypos + 1)); - "(" => (YYBEGIN INITIAL; - pushLevel (fn () => YYBEGIN XMLTAG); - Tokens.LPAREN (yypos, yypos + 1)); - - . => (ErrorMsg.errorAt' (yypos, yypos) - ("illegal XML tag character: \"" ^ yytext ^ "\""); - continue ()); - - "{" => (YYBEGIN INITIAL; - pushLevel (fn () => YYBEGIN XML); - Tokens.LBRACE (yypos, yypos + 1)); - - {notags} => (Tokens.NOTAGS (yytext, yypos, yypos + size yytext)); - - . => (ErrorMsg.errorAt' (yypos, yypos) - ("illegal XML character: \"" ^ yytext ^ "\""); - continue ()); - - "()" => (Tokens.UNIT (pos yypos, pos yypos + size yytext)); - "(" => (Tokens.LPAREN (pos yypos, pos yypos + size yytext)); - ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext)); - "[" => (Tokens.LBRACK (pos yypos, pos yypos + size yytext)); - "]" => (Tokens.RBRACK (pos yypos, pos yypos + size yytext)); - "{" => (enterBrace (); - Tokens.LBRACE (pos yypos, pos yypos + size yytext)); - "}" => (exitBrace (); - Tokens.RBRACE (pos yypos, pos yypos + size yytext)); - - "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); - "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); - "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); - "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); - - "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); - "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); - "<" => (Tokens.LT (pos yypos, pos yypos + size yytext)); - ">" => (Tokens.GT (pos yypos, pos yypos + size yytext)); - "<=" => (Tokens.LE (pos yypos, pos yypos + size yytext)); - ">=" => (Tokens.GE (pos yypos, pos yypos + size yytext)); - "," => (Tokens.COMMA (pos yypos, pos yypos + size yytext)); - ":::" => (Tokens.TCOLON (pos yypos, pos yypos + size yytext)); - "::" => (Tokens.DCOLON (pos yypos, pos yypos + size yytext)); - ":" => (Tokens.COLON (pos yypos, pos yypos + size yytext)); - "..." => (Tokens.DOTDOTDOT (pos yypos, pos yypos + size yytext)); - "." => (Tokens.DOT (pos yypos, pos yypos + size yytext)); - "$" => (Tokens.DOLLAR (pos yypos, pos yypos + size yytext)); - "#" => (Tokens.HASH (pos yypos, pos yypos + size yytext)); - "__" => (Tokens.UNDERUNDER (pos yypos, pos yypos + size yytext)); - "_" => (Tokens.UNDER (pos yypos, pos yypos + size yytext)); - "~" => (Tokens.TWIDDLE (pos yypos, pos yypos + size yytext)); - "|" => (Tokens.BAR (pos yypos, pos yypos + size yytext)); - "*" => (Tokens.STAR (pos yypos, pos yypos + size yytext)); - "<-" => (Tokens.LARROW (pos yypos, pos yypos + size yytext)); - ";" => (Tokens.SEMI (pos yypos, pos yypos + size yytext)); - - "con" => (Tokens.CON (pos yypos, pos yypos + size yytext)); - "type" => (Tokens.LTYPE (pos yypos, pos yypos + size yytext)); - "datatype" => (Tokens.DATATYPE (pos yypos, pos yypos + size yytext)); - "of" => (Tokens.OF (pos yypos, pos yypos + size yytext)); - "val" => (Tokens.VAL (pos yypos, pos yypos + size yytext)); - "rec" => (Tokens.REC (pos yypos, pos yypos + size yytext)); - "and" => (Tokens.AND (pos yypos, pos yypos + size yytext)); - "fun" => (Tokens.FUN (pos yypos, pos yypos + size yytext)); - "fn" => (Tokens.FN (pos yypos, pos yypos + size yytext)); - "fold" => (Tokens.FOLD (pos yypos, pos yypos + size yytext)); - "case" => (Tokens.CASE (pos yypos, pos yypos + size yytext)); - "if" => (Tokens.IF (pos yypos, pos yypos + size yytext)); - "then" => (Tokens.THEN (pos yypos, pos yypos + size yytext)); - "else" => (Tokens.ELSE (pos yypos, pos yypos + size yytext)); - - "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext)); - "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext)); - "struct" => (Tokens.STRUCT (pos yypos, pos yypos + size yytext)); - "sig" => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext)); - "end" => (Tokens.END (pos yypos, pos yypos + size yytext)); - "functor" => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext)); - "where" => (Tokens.WHERE (pos yypos, pos yypos + size yytext)); - "extern" => (Tokens.EXTERN (pos yypos, pos yypos + size yytext)); - "include" => (Tokens.INCLUDE (pos yypos, pos yypos + size yytext)); - "open" => (Tokens.OPEN (pos yypos, pos yypos + size yytext)); - "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext)); - "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext)); - "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); - "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); - "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); - - "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); - "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); - "Unit" => (Tokens.KUNIT (pos yypos, pos yypos + size yytext)); - - "SELECT" => (Tokens.SELECT (pos yypos, pos yypos + size yytext)); - "FROM" => (Tokens.FROM (pos yypos, pos yypos + size yytext)); - "AS" => (Tokens.AS (pos yypos, pos yypos + size yytext)); - "WHERE" => (Tokens.CWHERE (pos yypos, pos yypos + size yytext)); - "GROUP" => (Tokens.GROUP (pos yypos, pos yypos + size yytext)); - "ORDER" => (Tokens.ORDER (pos yypos, pos yypos + size yytext)); - "BY" => (Tokens.BY (pos yypos, pos yypos + size yytext)); - "HAVING" => (Tokens.HAVING (pos yypos, pos yypos + size yytext)); - "LIMIT" => (Tokens.LIMIT (pos yypos, pos yypos + size yytext)); - "OFFSET" => (Tokens.OFFSET (pos yypos, pos yypos + size yytext)); - "ALL" => (Tokens.ALL (pos yypos, pos yypos + size yytext)); - - "UNION" => (Tokens.UNION (pos yypos, pos yypos + size yytext)); - "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext)); - "EXCEPT" => (Tokens.EXCEPT (pos yypos, pos yypos + size yytext)); - - "TRUE" => (Tokens.TRUE (pos yypos, pos yypos + size yytext)); - "FALSE" => (Tokens.FALSE (pos yypos, pos yypos + size yytext)); - "AND" => (Tokens.CAND (pos yypos, pos yypos + size yytext)); - "OR" => (Tokens.OR (pos yypos, pos yypos + size yytext)); - "NOT" => (Tokens.NOT (pos yypos, pos yypos + size yytext)); - - "COUNT" => (Tokens.COUNT (pos yypos, pos yypos + size yytext)); - "AVG" => (Tokens.AVG (pos yypos, pos yypos + size yytext)); - "SUM" => (Tokens.SUM (pos yypos, pos yypos + size yytext)); - "MIN" => (Tokens.MIN (pos yypos, pos yypos + size yytext)); - "MAX" => (Tokens.MAX (pos yypos, pos yypos + size yytext)); - - {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); - {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); - - {intconst} => (case Int64.fromString yytext of - SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) - | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) - ("Expected int, received: " ^ yytext); - continue ())); - {realconst} => (case Real64.fromString yytext of - SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext) - | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) - ("Expected float, received: " ^ yytext); - continue ())); - - . => (continue()); - - . => (ErrorMsg.errorAt' (pos yypos, pos yypos) - ("illegal character: \"" ^ yytext ^ "\""); - continue ()); diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/mono_print.sig --- a/src/mono_print.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/mono_print.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web monomorphic language *) +(* Pretty-printing Ur/Web monomorphic language *) signature MONO_PRINT = sig val p_typ : MonoEnv.env -> Mono.typ Print.printer diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/mono_print.sml --- a/src/mono_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/mono_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing monomorphic Laconic/Web *) +(* Pretty-printing monomorphic Ur/Web *) structure MonoPrint :> MONO_PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/print.sml --- a/src/print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web *) +(* Generic printing support code *) structure Print :> PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/source_print.sig --- a/src/source_print.sig Thu Aug 28 14:48:33 2008 -0400 +++ b/src/source_print.sig Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web *) +(* Pretty-printing Ur/Web *) signature SOURCE_PRINT = sig val p_kind : Source.kind Print.printer diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/source_print.sml --- a/src/source_print.sml Thu Aug 28 14:48:33 2008 -0400 +++ b/src/source_print.sml Sun Aug 31 08:32:18 2008 -0400 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Pretty-printing Laconic/Web *) +(* Pretty-printing Ur/Web *) structure SourcePrint :> SOURCE_PRINT = struct diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/sources --- a/src/sources Thu Aug 28 14:48:33 2008 -0400 +++ b/src/sources Sun Aug 31 08:32:18 2008 -0400 @@ -18,8 +18,8 @@ source.sml -lacweb.grm -lacweb.lex +urweb.grm +urweb.lex source_print.sig source_print.sml diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/urweb.grm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/urweb.grm Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1055 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Grammar for Ur/Web programs *) + +open Source + +val s = ErrorMsg.spanOf +val dummy = ErrorMsg.dummySpan + +fun capitalize "" = "" + | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun entable t = + case #1 t of + TRecord c => c + | _ => t + +datatype select_item = + Field of con * con + | Exp of con * exp + +datatype select = + Star + | Items of select_item list + +datatype group_item = + GField of con * con + +fun eqTnames ((c1, _), (c2, _)) = + case (c1, c2) of + (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 + | (CName x1, CName x2) => x1 = x2 + | _ => false + +fun amend_select loc (si, (tabs, exps)) = + case si of + Field (tx, fx) => + let + val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + ((tx', (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + (tabs, exps) + end + | Exp (c, e) => (tabs, (c, e) :: exps) + +fun amend_group loc (gi, tabs) = + let + val (tx, c) = case gi of + GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + ((tx', (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + tabs + end + +fun sql_inject (v, t, loc) = + let + val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (t, loc)), loc) + in + (EApp (e, (v, loc)), loc) + end + +fun sql_compare (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_comparison"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_binary (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_binary"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_unary (oper, sqlexp, loc) = + let + val e = (EVar (["Basis"], "sql_unary"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + in + (EApp (e, sqlexp), loc) + end + +fun sql_relop (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_relop"), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +%% +%header (functor UrwebLrValsFn(structure Token : TOKEN)) + +%term + EOF + | STRING of string | INT of Int64.int | FLOAT of Real64.real + | SYMBOL of string | CSYMBOL of string + | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE + | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR + | DIVIDE | DOTDOTDOT + | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS + | DATATYPE | OF + | TYPE | NAME + | ARROW | LARROW | DARROW | STAR | SEMI + | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE + | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE + | CASE | IF | THEN | ELSE + + | XML_BEGIN of string | XML_END + | NOTAGS of string + | BEGIN_TAG of string | END_TAG of string + + | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING + | UNION | INTERSECT | EXCEPT + | LIMIT | OFFSET | ALL + | TRUE | FALSE | CAND | OR | NOT + | COUNT | AVG | SUM | MIN | MAX + | NE | LT | LE | GT | GE + +%nonterm + file of decl list + | decls of decl list + | decl of decl + | vali of string * con option * exp + | valis of (string * con option * exp) list + | copt of con option + + | dargs of string list + | barOpt of unit + | dcons of (string * con option) list + | dcon of string * con option + + | sgn of sgn + | sgntm of sgn + | sgi of sgn_item + | sgis of sgn_item list + + | str of str + + | kind of kind + | ktuple of kind list + | kcolon of explicitness + | kopt of kind option + + | path of string list * string + | cpath of string list * string + | spath of str + | mpath of string list + + | cexp of con + | capps of con + | cterm of con + | ctuple of con list + | ctuplev of con list + | ident of con + | idents of con list + | rcon of (con * con) list + | rconn of (con * con) list + | rcone of (con * con) list + | cargs of con * kind -> con * kind + | cargl of con * kind -> con * kind + | cargl2 of con * kind -> con * kind + | carg of con * kind -> con * kind + | cargp of con * kind -> con * kind + + | eexp of exp + | eapps of exp + | eterm of exp + | etuple of exp list + | rexp of (con * exp) list + | xml of exp + | xmlOne of exp + | tag of string * exp + | tagHead of string * exp + + | earg of exp * con -> exp * con + | eargp of exp * con -> exp * con + | eargs of exp * con -> exp * con + | eargl of exp * con -> exp * con + | eargl2 of exp * con -> exp * con + + | branch of pat * exp + | branchs of (pat * exp) list + | pat of pat + | pterm of pat + | rpat of (string * pat) list * bool + | ptuple of pat list + + | attrs of (con * exp) list + | attr of con * exp + | attrv of exp + + | query of exp + | query1 of exp + | tables of (con * exp) list + | tname of con + | table of con * exp + | tident of con + | fident of con + | seli of select_item + | selis of select_item list + | select of select + | sqlexp of exp + | wopt of exp + | groupi of group_item + | groupis of group_item list + | gopt of group_item list option + | hopt of exp + | obopt of exp + | obexps of exp + | lopt of exp + | ofopt of exp + | sqlint of exp + | sqlagg of string + + +%verbose (* print summary of errors *) +%pos int (* positions *) +%start file +%pure +%eop EOF +%noshift EOF + +%name Urweb + +%right SEMI +%nonassoc LARROW +%nonassoc IF THEN ELSE +%nonassoc DARROW +%nonassoc COLON +%nonassoc DCOLON TCOLON +%left UNION INTERSECT EXCEPT +%right COMMA +%right OR +%right CAND +%nonassoc EQ NE LT LE GT GE +%right ARROW +%right PLUSPLUS MINUSMINUS +%right STAR +%left NOT +%nonassoc TWIDDLE +%nonassoc DOLLAR +%left DOT +%nonassoc LBRACE RBRACE + +%% + +file : decls (decls) + | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), + s (SIGleft, sgisright))]) + +decls : ([]) + | decl decls (decl :: decls) + +decl : CON SYMBOL cargl2 kopt EQ cexp (let + val loc = s (CONleft, cexpright) + + val k = Option.getOpt (kopt, (KWild, loc)) + val (c, k) = cargl2 (cexp, k) + in + (DCon (SYMBOL, SOME k, c), loc) + end) + | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), + s (LTYPEleft, cexpright)) + | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + | _ => raise Fail "Arguments specified for imported datatype") + | VAL vali (DVal vali, s (VALleft, valiright)) + | VAL REC valis (DValRec valis, s (VALleft, valisright)) + | FUN valis (DValRec valis, s (FUNleft, valisright)) + + | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) + | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright)) + | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str + (DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str + (DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright)) + | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright)) + | OPEN mpath (case mpath of + [] => raise Fail "Impossible mpath parse [1]" + | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright))) + | OPEN CONSTRAINTS mpath (case mpath of + [] => raise Fail "Impossible mpath parse [3]" + | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) + | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) + | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) + | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) + | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + val k = (KType, loc) + val c = (CAbs (SYMBOL2, SOME k, cexp), loc) + in + (DClass (SYMBOL1, c), s (CLASSleft, cexpright)) + end) + +kopt : (NONE) + | DCOLON kind (SOME kind) + +dargs : ([]) + | SYMBOL dargs (SYMBOL :: dargs) + +barOpt : () + | BAR () + +dcons : dcon ([dcon]) + | dcon BAR dcons (dcon :: dcons) + +dcon : CSYMBOL (CSYMBOL, NONE) + | CSYMBOL OF cexp (CSYMBOL, SOME cexp) + +vali : SYMBOL eargl2 copt EQ eexp (let + val loc = s (SYMBOLleft, eexpright) + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + + val (e, t) = eargl2 (eexp, t) + in + (SYMBOL, SOME t, e) + end) + +copt : (NONE) + | COLON cexp (SOME cexp) + +valis : vali ([vali]) + | vali AND valis (vali :: valis) + +sgn : sgntm (sgntm) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right)) + +sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) + | mpath (case mpath of + [] => raise Fail "Impossible mpath parse [2]" + | [x] => SgnVar x + | m :: ms => SgnProj (m, + List.take (ms, length ms - 1), + List.nth (ms, length ms - 1)), + s (mpathleft, mpathright)) + | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) + | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright)) + | LPAREN sgn RPAREN (sgn) + +sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright)) + | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))), + s (LTYPEleft, SYMBOLright)) + | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)) + | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)) + | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), + s (LTYPEleft, cexpright)) + | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + | _ => raise Fail "Arguments specified for imported datatype") + | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright)) + + | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)) + | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + (SgiStr (CSYMBOL1, + (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))), + s (FUNCTORleft, sgn2right)) + | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) + | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) + | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) + | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) + | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + val k = (KType, loc) + val c = (CAbs (SYMBOL2, SOME k, cexp), loc) + in + (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) + end) + +sgis : ([]) + | sgi sgis (sgi :: sgis) + +str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright)) + | spath (spath) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str + (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright)) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str + (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)) + | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright)) + +spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright)) + +kind : TYPE (KType, s (TYPEleft, TYPEright)) + | NAME (KName, s (NAMEleft, NAMEright)) + | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) + | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) + | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) + | KUNIT (KUnit, s (KUNITleft, KUNITright)) + | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) + | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) + +ktuple : kind STAR kind ([kind1, kind2]) + | kind STAR ktuple (kind :: ktuple) + +capps : cterm (cterm) + | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) + +cexp : capps (capps) + | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) + | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) + + | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) + + | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) + | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) + | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright)) + + | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) + + | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright)) + | ctuple (let + val loc = s (ctupleleft, ctupleright) + in + (TRecord (CRecord (ListUtil.mapi (fn (i, c) => + ((CName (Int.toString (i + 1)), loc), + c)) ctuple), + loc), loc) + end) + +kcolon : DCOLON (Explicit) + | TCOLON (Implicit) + +cargs : carg (carg) + | cargl (cargl) + +cargl : cargp cargp (cargp1 o cargp2) + | cargp cargl (cargp o cargl) + +cargl2 : (fn x => x) + | cargp cargl2 (cargp o cargl2) + +carg : SYMBOL DCOLON kind (fn (c, k) => + let + val loc = s (SYMBOLleft, kindright) + in + ((CAbs (SYMBOL, SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + | cargp (cargp) + +cargp : SYMBOL (fn (c, k) => + let + val loc = s (SYMBOLleft, SYMBOLright) + in + ((CAbs (SYMBOL, NONE, c), loc), + (KArrow ((KWild, loc), k), loc)) + end) + | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) => + let + val loc = s (LPARENleft, RPARENright) + in + ((CAbs (SYMBOL, SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + +path : SYMBOL ([], SYMBOL) + | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end) + +cpath : CSYMBOL ([], CSYMBOL) + | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end) + +mpath : CSYMBOL ([CSYMBOL]) + | CSYMBOL DOT mpath (CSYMBOL :: mpath) + +cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) + | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) + | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright)) + | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), + s (LBRACEleft, RBRACEright)) + | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) + | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) + | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright)) + + | path (CVar path, s (pathleft, pathright)) + | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT), + s (pathleft, INTright)) + | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright)) + | FOLD (CFold, s (FOLDleft, FOLDright)) + | UNIT (CUnit, s (UNITleft, UNITright)) + | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright)) + +ctuplev: cexp COMMA cexp ([cexp1, cexp2]) + | cexp COMMA ctuplev (cexp :: ctuplev) + +ctuple : capps STAR capps ([capps1, capps2]) + | capps STAR ctuple (capps :: ctuple) + +rcon : ([]) + | ident EQ cexp ([(ident, cexp)]) + | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon) + +rconn : ident ([(ident, (CUnit, s (identleft, identright)))]) + | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn) + +rcone : ([]) + | ident COLON cexp ([(ident, cexp)]) + | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone) + +ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | INT (CName (Int64.toString INT), s (INTleft, INTright)) + | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)) + +eapps : eterm (eterm) + | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) + | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) + +eexp : eapps (eapps) + | FN eargs DARROW eexp (let + val loc = s (FNleft, eexpright) + in + #1 (eargs (eexp, (CWild (KType, loc), loc))) + end) + | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright)) + | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) + | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) + | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) + | IF eexp THEN eexp ELSE eexp (let + val loc = s (IFleft, eexp3right) + in + (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), + ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) + end) + | SYMBOL LARROW eexp SEMI eexp (let + val loc = s (SYMBOLleft, eexp2right) + val e = (EVar (["Basis"], "bind"), loc) + val e = (EApp (e, eexp1), loc) + in + (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc) + end) + +eargs : earg (earg) + | eargl (eargl) + +eargl : eargp eargp (eargp1 o eargp2) + | eargp eargl (eargp o eargl) + +eargl2 : (fn x => x) + | eargp eargl2 (eargp o eargl2) + +earg : SYMBOL kcolon kind (fn (e, t) => + let + val loc = s (SYMBOLleft, kindright) + in + ((ECAbs (kcolon, SYMBOL, kind, e), loc), + (TCFun (kcolon, SYMBOL, kind, t), loc)) + end) + | SYMBOL COLON cexp (fn (e, t) => + let + val loc = s (SYMBOLleft, cexpright) + in + ((EAbs (SYMBOL, SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | UNDER COLON cexp (fn (e, t) => + let + val loc = s (UNDERleft, cexpright) + in + ((EAbs ("_", SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | eargp (eargp) + +eargp : SYMBOL (fn (e, t) => + let + val loc = s (SYMBOLleft, SYMBOLright) + in + ((EAbs (SYMBOL, NONE, e), loc), + (TFun ((CWild (KType, loc), loc), t), loc)) + end) + | UNIT (fn (e, t) => + let + val loc = s (UNITleft, UNITright) + val t' = (TRecord (CRecord [], loc), loc) + in + ((EAbs ("_", SOME t', e), loc), + (TFun (t', t), loc)) + end) + | UNDER (fn (e, t) => + let + val loc = s (UNDERleft, UNDERright) + in + ((EAbs ("_", NONE, e), loc), + (TFun ((CWild (KType, loc), loc), t), loc)) + end) + | LPAREN SYMBOL kcolon kind RPAREN(fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((ECAbs (kcolon, SYMBOL, kind, e), loc), + (TCFun (kcolon, SYMBOL, kind, t), loc)) + end) + | LPAREN SYMBOL COLON cexp RPAREN (fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((EAbs (SYMBOL, SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + | LPAREN UNDER COLON cexp RPAREN (fn (e, t) => + let + val loc = s (LPARENleft, RPARENright) + in + ((EAbs ("_", SOME cexp, e), loc), + (TFun (cexp, t), loc)) + end) + +eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) + | LPAREN etuple RPAREN (let + val loc = s (LPARENleft, RPARENright) + in + (ERecord (ListUtil.mapi (fn (i, e) => + ((CName (Int.toString (i + 1)), loc), + e)) etuple), loc) + end) + + | path (EVar path, s (pathleft, pathright)) + | cpath (EVar cpath, s (cpathleft, cpathright)) + | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | UNIT (ERecord [], s (UNITleft, UNITright)) + + | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + + | path DOT idents (let + val loc = s (pathleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + (EVar path, s (pathleft, pathright)) idents + end) + | FOLD (EFold, s (FOLDleft, FOLDright)) + + | XML_BEGIN xml XML_END (xml) + | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)), + (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))), + s (XML_BEGINleft, XML_ENDright)) + | LPAREN query RPAREN (query) + | UNDER (EWild, s (UNDERleft, UNDERright)) + +idents : ident ([ident]) + | ident DOT idents (ident :: idents) + +etuple : eexp COMMA eexp ([eexp1, eexp2]) + | eexp COMMA etuple (eexp :: etuple) + +branch : pat DARROW eexp (pat, eexp) + +branchs: ([]) + | BAR branch branchs (branch :: branchs) + +pat : pterm (pterm) + | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright)) + +pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) + | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) + | UNDER (PWild, s (UNDERleft, UNDERright)) + | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) + | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LPAREN pat RPAREN (pat) + | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) + | UNIT (PRecord ([], false), s (UNITleft, UNITright)) + | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) + | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple, + false), + s (LPARENleft, RPARENright)) + +rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) + | INT EQ pat ([(Int64.toString INT, pat)], false) + | DOTDOTDOT ([], true) + | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat) + | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat) + +ptuple : pat COMMA pat ([pat1, pat2]) + | pat COMMA ptuple (pat :: ptuple) + +rexp : ([]) + | ident EQ eexp ([(ident, eexp)]) + | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp) + +xml : xmlOne xml (let + val pos = s (xmlOneleft, xmlright) + in + (EApp ((EApp ( + (EVar (["Basis"], "join"), pos), + xmlOne), pos), + xml), pos) + end) + | xmlOne (xmlOne) + +xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)), + (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), + s (NOTAGSleft, NOTAGSright)) + | tag DIVIDE GT (let + val pos = s (tagleft, GTright) + in + (EApp (#2 tag, + (EApp ((EVar (["Basis"], "cdata"), pos), + (EPrim (Prim.String ""), pos)), + pos)), pos) + end) + + | tag GT xml END_TAG (let + val pos = s (tagleft, GTright) + in + if #1 tag = END_TAG then + if END_TAG = "lform" then + (EApp ((EVar (["Basis"], "lform"), pos), + xml), pos) + else + (EApp (#2 tag, xml), pos) + else + (ErrorMsg.errorAt pos "Begin and end tags don't match."; + (EFold, pos)) + end) + | LBRACE eexp RBRACE (eexp) + +tag : tagHead attrs (let + val pos = s (tagHeadleft, attrsright) + in + (#1 tagHead, + (EApp ((EApp ((EVar (["Basis"], "tag"), pos), + (ERecord attrs, pos)), pos), + (EApp (#2 tagHead, + (ERecord [], pos)), pos)), + pos)) + end) + +tagHead: BEGIN_TAG (let + val pos = s (BEGIN_TAGleft, BEGIN_TAGright) + in + (BEGIN_TAG, + (EVar ([], BEGIN_TAG), pos)) + end) + | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) + +attrs : ([]) + | attr attrs (attr :: attrs) + +attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv) + +attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LBRACE eexp RBRACE (eexp) + +query : query1 obopt lopt ofopt (let + val loc = s (query1left, query1right) + + val re = (ERecord [((CName "Rows", loc), + query1), + ((CName "OrderBy", loc), + obopt), + ((CName "Limit", loc), + lopt), + ((CName "Offset", loc), + ofopt)], loc) + in + (EApp ((EVar (["Basis"], "sql_query"), loc), re), loc) + end) + +query1 : SELECT select FROM tables wopt gopt hopt + (let + val loc = s (SELECTleft, tablesright) + + val (sel, exps) = + case select of + Star => (map (fn (nm, _) => + (nm, (CTuple [(CWild (KRecord (KType, loc), loc), + loc), + (CRecord [], loc)], + loc))) tables, + []) + | Items sis => + let + val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables + val (tabs, exps) = foldl (amend_select loc) (tabs, []) sis + in + (map (fn (nm, c) => (nm, + (CTuple [c, + (CWild (KRecord (KType, loc), loc), + loc)], loc))) tabs, + exps) + end + + val sel = (CRecord sel, loc) + + val grp = case gopt of + NONE => (ECApp ((EVar (["Basis"], "sql_subset_all"), loc), + (CWild (KRecord (KRecord (KType, loc), loc), + loc), loc)), loc) + | SOME gis => + let + val tabs = map (fn (nm, _) => + (nm, (CRecord [], loc))) tables + val tabs = foldl (amend_group loc) tabs gis + + val tabs = map (fn (nm, c) => + (nm, + (CTuple [c, + (CWild (KRecord (KType, loc), + loc), + loc)], loc))) tabs + in + (ECApp ((EVar (["Basis"], "sql_subset"), loc), + (CRecord tabs, loc)), loc) + end + + val e = (EVar (["Basis"], "sql_query1"), loc) + val re = (ERecord [((CName "From", loc), + (ERecord tables, loc)), + ((CName "Where", loc), + wopt), + ((CName "GroupBy", loc), + grp), + ((CName "Having", loc), + hopt), + ((CName "SelectFields", loc), + (ECApp ((EVar (["Basis"], "sql_subset"), loc), + sel), loc)), + ((CName "SelectExps", loc), + (ERecord exps, loc))], loc) + + val e = (EApp (e, re), loc) + in + e + end) + | query1 UNION query1 (sql_relop ("union", query11, query12, s (query11left, query12right))) + | query1 INTERSECT query1 (sql_relop ("intersect", query11, query12, s (query11left, query12right))) + | query1 EXCEPT query1 (sql_relop ("except", query11, query12, s (query11left, query12right))) + +tables : table ([table]) + | table COMMA tables (table :: tables) + +tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), + (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) + | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))) + | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp) + +tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)) + | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE LBRACE cexp RBRACE RBRACE (cexp) + +fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +seli : tident DOT fident (Field (tident, fident)) + | sqlexp AS fident (Exp (fident, sqlexp)) + +selis : seli ([seli]) + | seli COMMA selis (seli :: selis) + +select : STAR (Star) + | selis (Items selis) + +sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + s (TRUEleft, TRUEright))) + | FALSE (sql_inject (EVar (["Basis"], "False"), + EVar (["Basis"], "sql_bool"), + s (FALSEleft, FALSEright))) + + | INT (sql_inject (EPrim (Prim.Int INT), + EVar (["Basis"], "sql_int"), + s (INTleft, INTright))) + | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), + EVar (["Basis"], "sql_float"), + s (FLOATleft, FLOATright))) + | STRING (sql_inject (EPrim (Prim.String STRING), + EVar (["Basis"], "sql_string"), + s (STRINGleft, STRINGright))) + + | tident DOT fident (let + val loc = s (tidentleft, fidentright) + val e = (EVar (["Basis"], "sql_field"), loc) + val e = (ECApp (e, tident), loc) + in + (ECApp (e, fident), loc) + end) + | CSYMBOL (let + val loc = s (CSYMBOLleft, CSYMBOLright) + val e = (EVar (["Basis"], "sql_exp"), loc) + in + (ECApp (e, (CName CSYMBOL, loc)), loc) + end) + + | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + + | LBRACE eexp RBRACE (sql_inject (#1 eexp, + EWild, + s (LBRACEleft, RBRACEright))) + | LPAREN sqlexp RPAREN (sqlexp) + + | COUNT LPAREN STAR RPAREN (let + val loc = s (COUNTleft, RPARENright) + in + (EApp ((EVar (["Basis"], "sql_count"), loc), + (ERecord [], loc)), loc) + end) + | sqlagg LPAREN sqlexp RPAREN (let + val loc = s (sqlaggleft, RPARENright) + + val e = (EApp ((EVar (["Basis"], "sql_" ^ sqlagg), loc), + (EWild, loc)), loc) + val e = (EApp ((EVar (["Basis"], "sql_aggregate"), loc), + e), loc) + in + (EApp (e, sqlexp), loc) + end) + +wopt : (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + dummy)) + | CWHERE sqlexp (sqlexp) + +groupi : tident DOT fident (GField (tident, fident)) + +groupis: groupi ([groupi]) + | groupi COMMA groupis (groupi :: groupis) + +gopt : (NONE) + | GROUP BY groupis (SOME groupis) + +hopt : (sql_inject (EVar (["Basis"], "True"), + EVar (["Basis"], "sql_bool"), + dummy)) + | HAVING sqlexp (sqlexp) + +obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), dummy), + (CWild (KRecord (KType, dummy), dummy), dummy)), + dummy) + | ORDER BY obexps (obexps) + +obexps : sqlexp (let + val loc = s (sqlexpleft, sqlexpright) + + val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil"), loc), + (CWild (KRecord (KType, loc), loc), loc)), + loc) + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), + sqlexp), loc) + in + (EApp (e, e'), loc) + end) + | sqlexp COMMA obexps (let + val loc = s (sqlexpleft, obexpsright) + + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons"), loc), + sqlexp), loc) + in + (EApp (e, obexps), loc) + end) + +lopt : (EVar (["Basis"], "sql_no_limit"), dummy) + | LIMIT ALL (EVar (["Basis"], "sql_no_limit"), dummy) + | LIMIT sqlint (let + val loc = s (LIMITleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_limit"), loc), sqlint), loc) + end) + +ofopt : (EVar (["Basis"], "sql_no_offset"), dummy) + | OFFSET sqlint (let + val loc = s (OFFSETleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_offset"), loc), sqlint), loc) + end) + +sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | LBRACE eexp RBRACE (eexp) + +sqlagg : AVG ("avg") + | SUM ("sum") + | MIN ("min") + | MAX ("max") diff -r 2b9dfaffb008 -r 71bafe66dbe1 src/urweb.lex --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/urweb.lex Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,353 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Lexing info for Ur/Web programs *) + +type pos = int +type svalue = Tokens.svalue +type ('a,'b) token = ('a,'b) Tokens.token +type lexresult = (svalue,pos) Tokens.token + +local + val commentLevel = ref 0 + val commentPos = ref 0 +in + fun enterComment pos = + (if !commentLevel = 0 then + commentPos := pos + else + (); + commentLevel := !commentLevel + 1) + + fun exitComment () = + (ignore (commentLevel := !commentLevel - 1); + !commentLevel = 0) + + fun eof () = + let + val pos = ErrorMsg.lastLineStart () + in + if !commentLevel > 0 then + ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" + else + (); + Tokens.EOF (pos, pos) + end +end + +val strEnder = ref #"\"" +val str = ref ([] : char list) +val strStart = ref 0 + +local + val initSig = ref false + val offset = ref 0 +in + +fun initialSig () = initSig := true + +fun pos yypos = yypos - !offset + +fun newline yypos = + if !initSig then + (initSig := false; + offset := yypos + 1) + else + ErrorMsg.newline (pos yypos) + +end + +val xmlTag = ref ([] : string list) +val xmlString = ref true +val braceLevels = ref ([] : ((unit -> unit) * int) list) + +fun pushLevel s = braceLevels := (s, 1) :: (!braceLevels) + +fun enterBrace () = + case !braceLevels of + (s, i) :: rest => braceLevels := (s, i+1) :: rest + | _ => () + +fun exitBrace () = + case !braceLevels of + (s, i) :: rest => + if i = 1 then + (braceLevels := rest; + s ()) + else + braceLevels := (s, i-1) :: rest + | _ => () + +fun initialize () = (xmlTag := []; + xmlString := false) + + +%% +%header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); +%full +%s COMMENT STRING XML XMLTAG; + +id = [a-z_][A-Za-z0-9_']*; +cid = [A-Z][A-Za-z0-9_']*; +ws = [\ \t\012]; +intconst = [0-9]+; +realconst = [0-9]+\.[0-9]*; +notags = [^<{\n]+; + +%% + + \n => (newline yypos; + continue ()); + \n => (newline yypos; + continue ()); + \n => (newline yypos; + continue ()); + \n => (newline yypos; + Tokens.NOTAGS (yytext, yypos, yypos + size yytext)); + + {ws}+ => (lex ()); + + "(*" => (YYBEGIN COMMENT; + enterComment (pos yypos); + continue ()); + "*)" => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments"; + continue ()); + + "(*" => (enterComment (pos yypos); + continue ()); + "*)" => (if exitComment () then YYBEGIN INITIAL else (); + continue ()); + + "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); + "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); + "\\\"" => (str := #"\"" :: !str; continue()); + "\\'" => (str := #"'" :: !str; continue()); + "\n" => (newline yypos; + str := #"\n" :: !str; continue()); + . => (let + val ch = String.sub (yytext, 0) + in + if ch = !strEnder then + (if !xmlString then + (xmlString := false; YYBEGIN XMLTAG) + else + YYBEGIN INITIAL; + Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1)) + else + (str := ch :: !str; + continue ()) + end); + + "<" {id} ">"=> (let + val tag = String.substring (yytext, 1, size yytext - 2) + in + YYBEGIN XML; + xmlTag := tag :: (!xmlTag); + Tokens.XML_BEGIN (tag, yypos, yypos + size yytext) + end); + "" => (let + val id = String.substring (yytext, 2, size yytext - 3) + in + case !xmlTag of + id' :: rest => + if id = id' then + (YYBEGIN INITIAL; + xmlTag := rest; + Tokens.XML_END (yypos, yypos + size yytext)) + else + Tokens.END_TAG (id, yypos, yypos + size yytext) + | _ => + Tokens.END_TAG (id, yypos, yypos + size yytext) + end); + + "<" {id} => (YYBEGIN XMLTAG; + Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE), + yypos, yypos + size yytext)); + + "/" => (Tokens.DIVIDE (yypos, yypos + size yytext)); + ">" => (YYBEGIN XML; + Tokens.GT (yypos, yypos + size yytext)); + + {ws}+ => (lex ()); + + {id} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); + "=" => (Tokens.EQ (yypos, yypos + size yytext)); + + {intconst} => (case Int64.fromString yytext of + SOME x => Tokens.INT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected int, received: " ^ yytext); + continue ())); + {realconst} => (case Real.fromString yytext of + SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected float, received: " ^ yytext); + continue ())); + "\"" => (YYBEGIN STRING; + xmlString := true; + strStart := yypos; str := []; continue ()); + + "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XMLTAG); + Tokens.LBRACE (yypos, yypos + 1)); + "(" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XMLTAG); + Tokens.LPAREN (yypos, yypos + 1)); + + . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML tag character: \"" ^ yytext ^ "\""); + continue ()); + + "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XML); + Tokens.LBRACE (yypos, yypos + 1)); + + {notags} => (Tokens.NOTAGS (yytext, yypos, yypos + size yytext)); + + . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML character: \"" ^ yytext ^ "\""); + continue ()); + + "()" => (Tokens.UNIT (pos yypos, pos yypos + size yytext)); + "(" => (Tokens.LPAREN (pos yypos, pos yypos + size yytext)); + ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext)); + "[" => (Tokens.LBRACK (pos yypos, pos yypos + size yytext)); + "]" => (Tokens.RBRACK (pos yypos, pos yypos + size yytext)); + "{" => (enterBrace (); + Tokens.LBRACE (pos yypos, pos yypos + size yytext)); + "}" => (exitBrace (); + Tokens.RBRACE (pos yypos, pos yypos + size yytext)); + + "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); + "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); + "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); + "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); + + "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); + "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); + "<" => (Tokens.LT (pos yypos, pos yypos + size yytext)); + ">" => (Tokens.GT (pos yypos, pos yypos + size yytext)); + "<=" => (Tokens.LE (pos yypos, pos yypos + size yytext)); + ">=" => (Tokens.GE (pos yypos, pos yypos + size yytext)); + "," => (Tokens.COMMA (pos yypos, pos yypos + size yytext)); + ":::" => (Tokens.TCOLON (pos yypos, pos yypos + size yytext)); + "::" => (Tokens.DCOLON (pos yypos, pos yypos + size yytext)); + ":" => (Tokens.COLON (pos yypos, pos yypos + size yytext)); + "..." => (Tokens.DOTDOTDOT (pos yypos, pos yypos + size yytext)); + "." => (Tokens.DOT (pos yypos, pos yypos + size yytext)); + "$" => (Tokens.DOLLAR (pos yypos, pos yypos + size yytext)); + "#" => (Tokens.HASH (pos yypos, pos yypos + size yytext)); + "__" => (Tokens.UNDERUNDER (pos yypos, pos yypos + size yytext)); + "_" => (Tokens.UNDER (pos yypos, pos yypos + size yytext)); + "~" => (Tokens.TWIDDLE (pos yypos, pos yypos + size yytext)); + "|" => (Tokens.BAR (pos yypos, pos yypos + size yytext)); + "*" => (Tokens.STAR (pos yypos, pos yypos + size yytext)); + "<-" => (Tokens.LARROW (pos yypos, pos yypos + size yytext)); + ";" => (Tokens.SEMI (pos yypos, pos yypos + size yytext)); + + "con" => (Tokens.CON (pos yypos, pos yypos + size yytext)); + "type" => (Tokens.LTYPE (pos yypos, pos yypos + size yytext)); + "datatype" => (Tokens.DATATYPE (pos yypos, pos yypos + size yytext)); + "of" => (Tokens.OF (pos yypos, pos yypos + size yytext)); + "val" => (Tokens.VAL (pos yypos, pos yypos + size yytext)); + "rec" => (Tokens.REC (pos yypos, pos yypos + size yytext)); + "and" => (Tokens.AND (pos yypos, pos yypos + size yytext)); + "fun" => (Tokens.FUN (pos yypos, pos yypos + size yytext)); + "fn" => (Tokens.FN (pos yypos, pos yypos + size yytext)); + "fold" => (Tokens.FOLD (pos yypos, pos yypos + size yytext)); + "case" => (Tokens.CASE (pos yypos, pos yypos + size yytext)); + "if" => (Tokens.IF (pos yypos, pos yypos + size yytext)); + "then" => (Tokens.THEN (pos yypos, pos yypos + size yytext)); + "else" => (Tokens.ELSE (pos yypos, pos yypos + size yytext)); + + "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext)); + "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext)); + "struct" => (Tokens.STRUCT (pos yypos, pos yypos + size yytext)); + "sig" => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext)); + "end" => (Tokens.END (pos yypos, pos yypos + size yytext)); + "functor" => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext)); + "where" => (Tokens.WHERE (pos yypos, pos yypos + size yytext)); + "extern" => (Tokens.EXTERN (pos yypos, pos yypos + size yytext)); + "include" => (Tokens.INCLUDE (pos yypos, pos yypos + size yytext)); + "open" => (Tokens.OPEN (pos yypos, pos yypos + size yytext)); + "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext)); + "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext)); + "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); + "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); + "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); + + "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); + "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); + "Unit" => (Tokens.KUNIT (pos yypos, pos yypos + size yytext)); + + "SELECT" => (Tokens.SELECT (pos yypos, pos yypos + size yytext)); + "FROM" => (Tokens.FROM (pos yypos, pos yypos + size yytext)); + "AS" => (Tokens.AS (pos yypos, pos yypos + size yytext)); + "WHERE" => (Tokens.CWHERE (pos yypos, pos yypos + size yytext)); + "GROUP" => (Tokens.GROUP (pos yypos, pos yypos + size yytext)); + "ORDER" => (Tokens.ORDER (pos yypos, pos yypos + size yytext)); + "BY" => (Tokens.BY (pos yypos, pos yypos + size yytext)); + "HAVING" => (Tokens.HAVING (pos yypos, pos yypos + size yytext)); + "LIMIT" => (Tokens.LIMIT (pos yypos, pos yypos + size yytext)); + "OFFSET" => (Tokens.OFFSET (pos yypos, pos yypos + size yytext)); + "ALL" => (Tokens.ALL (pos yypos, pos yypos + size yytext)); + + "UNION" => (Tokens.UNION (pos yypos, pos yypos + size yytext)); + "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext)); + "EXCEPT" => (Tokens.EXCEPT (pos yypos, pos yypos + size yytext)); + + "TRUE" => (Tokens.TRUE (pos yypos, pos yypos + size yytext)); + "FALSE" => (Tokens.FALSE (pos yypos, pos yypos + size yytext)); + "AND" => (Tokens.CAND (pos yypos, pos yypos + size yytext)); + "OR" => (Tokens.OR (pos yypos, pos yypos + size yytext)); + "NOT" => (Tokens.NOT (pos yypos, pos yypos + size yytext)); + + "COUNT" => (Tokens.COUNT (pos yypos, pos yypos + size yytext)); + "AVG" => (Tokens.AVG (pos yypos, pos yypos + size yytext)); + "SUM" => (Tokens.SUM (pos yypos, pos yypos + size yytext)); + "MIN" => (Tokens.MIN (pos yypos, pos yypos + size yytext)); + "MAX" => (Tokens.MAX (pos yypos, pos yypos + size yytext)); + + {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); + {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); + + {intconst} => (case Int64.fromString yytext of + SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected int, received: " ^ yytext); + continue ())); + {realconst} => (case Real64.fromString yytext of + SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected float, received: " ^ yytext); + continue ())); + + . => (continue()); + + . => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("illegal character: \"" ^ yytext ^ "\""); + continue ()); diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/agg.lac --- a/tests/agg.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT COUNT( * ) AS X FROM t1) -val q2 = (SELECT AVG(t1.A) AS X FROM t1) -val q3 = (SELECT SUM(t1.C) AS X FROM t1) -val q4 = (SELECT MIN(t1.B) AS X, MAX(t1.A) AS Y FROM t1) - -(*val q5 = (SELECT t1.A FROM t1 GROUP BY t1.B)*) -val q5 = (SELECT SUM(t1.A) AS X FROM t1 GROUP BY t1.B) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/agg.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/agg.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT COUNT( * ) AS X FROM t1) +val q2 = (SELECT AVG(t1.A) AS X FROM t1) +val q3 = (SELECT SUM(t1.C) AS X FROM t1) +val q4 = (SELECT MIN(t1.B) AS X, MAX(t1.A) AS Y FROM t1) + +(*val q5 = (SELECT t1.A FROM t1 GROUP BY t1.B)*) +val q5 = (SELECT SUM(t1.A) AS X FROM t1 GROUP BY t1.B) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/attrs.lac --- a/tests/attrs.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -val main = fn () => - Welcome - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/attrs.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/attrs.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,3 @@ +val main = fn () => + Welcome + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/attrs_escape.lac --- a/tests/attrs_escape.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -val main = fn () => - Welcome - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/attrs_escape.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/attrs_escape.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,4 @@ +val main = fn () => + Welcome + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/bool.lac --- a/tests/bool.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val page = fn b => - {cdata (case b of False => "No!" | True => "Yes!")} - - -val main : unit -> page = fn () => -
  • True
    • -
  • False
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/bool.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/bool.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val page = fn b => + {cdata (case b of False => "No!" | True => "Yes!")} + + +val main : unit -> page = fn () => +
  • True
    • +
  • False
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/broad_unif.lac --- a/tests/broad_unif.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -structure M = struct - type t = int - val f = fn x => x - val y = f 0 -end - -signature S = sig - type t - val f : t -> t -end - -structure M : S = struct - type t = int - val f = fn x => x -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/broad_unif.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/broad_unif.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +structure M = struct + type t = int + val f = fn x => x + val y = f 0 +end + +signature S = sig + type t + val f : t -> t +end + +structure M : S = struct + type t = int + val f = fn x => x +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cargs.lac --- a/tests/cargs.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -con id = fn t :: Type => t -con id2 = fn (t :: Type) => id t -con id3 = fn t => id2 t - -con pair = fn (t :: Type) (u :: Type) => (t, u) -con pair2 = fn t u => pair t u -con pair3 = fn t (u :: Type) => pair2 t u - -con id4 (t :: Type) = t -con id5 (t :: Type) :: Type = id4 t -con id6 t :: Type = id5 t - -con pair4 t (u :: Type) = pair3 t u -con pair5 t (u :: Type) :: (Type * Type) = pair4 t u diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cargs.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cargs.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,14 @@ +con id = fn t :: Type => t +con id2 = fn (t :: Type) => id t +con id3 = fn t => id2 t + +con pair = fn (t :: Type) (u :: Type) => (t, u) +con pair2 = fn t u => pair t u +con pair3 = fn t (u :: Type) => pair2 t u + +con id4 (t :: Type) = t +con id5 (t :: Type) :: Type = id4 t +con id6 t :: Type = id5 t + +con pair4 t (u :: Type) = pair3 t u +con pair5 t (u :: Type) :: (Type * Type) = pair4 t u diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/case.lac --- a/tests/case.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -datatype t = A | B - -val swap = fn x : t => case x of A => B | B => A - -datatype u = C of t | D - -val out = fn x : u => case x of C y => y | D => A - -datatype nat = O | S of nat - -val is_two = fn x : nat => - case x of S (S O) => A | _ => B - -val zero_is_two = is_two O -val one_is_two = is_two (S O) -val two_is_two = is_two (S (S O)) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/case.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/case.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,16 @@ +datatype t = A | B + +val swap = fn x : t => case x of A => B | B => A + +datatype u = C of t | D + +val out = fn x : u => case x of C y => y | D => A + +datatype nat = O | S of nat + +val is_two = fn x : nat => + case x of S (S O) => A | _ => B + +val zero_is_two = is_two O +val one_is_two = is_two (S O) +val two_is_two = is_two (S (S O)) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/caseFfi.lac --- a/tests/caseFfi.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -extern structure M : sig - datatype t = A | B - datatype u = C of t | D -end - -val f = fn x => case x of M.A => M.B | M.B => M.A - -val t2s = fn x => case x of M.A => "A" | M.B => "B" - -val g = fn x => case x of M.C a => M.C (f a) | M.D => M.C M.A - -val u2s = fn x => case x of M.C a => t2s a | M.D => "D" - -val page = fn x => - {cdata (t2s x)} - - -val page2 = fn x => - {cdata (u2s x)} - - -val main : unit -> page = fn () => -
  • A
    • -
  • B
    • -
  • C A
    • -
  • C B
    • -
  • D
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/caseFfi.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/caseFfi.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,28 @@ +extern structure M : sig + datatype t = A | B + datatype u = C of t | D +end + +val f = fn x => case x of M.A => M.B | M.B => M.A + +val t2s = fn x => case x of M.A => "A" | M.B => "B" + +val g = fn x => case x of M.C a => M.C (f a) | M.D => M.C M.A + +val u2s = fn x => case x of M.C a => t2s a | M.D => "D" + +val page = fn x => + {cdata (t2s x)} + + +val page2 = fn x => + {cdata (u2s x)} + + +val main : unit -> page = fn () => +
  • A
    • +
  • B
    • +
  • C A
    • +
  • C B
    • +
  • D
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/caseMod.lac --- a/tests/caseMod.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -structure M = struct - datatype t = A | B -end - -val f = fn x : M.t => case x of M.A => M.B | M.B => M.A - -datatype t = datatype M.t - -val g = fn x : t => case x of M.A => B | B => M.A - -structure N = struct - datatype u = C of t | D -end - -val h = fn x : N.u => case x of N.C x => x | N.D => M.A - -datatype u = datatype N.u - -val i = fn x : u => case x of N.C x => x | D => M.A - -val toString = fn x => - case x of - C A => "C A" - | C B => "C B" - | D => "D" - -val rec page = fn x => - {cdata (toString x)}
    -
    - - Again! - - -val main : unit -> page = fn () => -
  • C A
    • -
  • C B
    • -
  • D
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/caseMod.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/caseMod.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,38 @@ +structure M = struct + datatype t = A | B +end + +val f = fn x : M.t => case x of M.A => M.B | M.B => M.A + +datatype t = datatype M.t + +val g = fn x : t => case x of M.A => B | B => M.A + +structure N = struct + datatype u = C of t | D +end + +val h = fn x : N.u => case x of N.C x => x | N.D => M.A + +datatype u = datatype N.u + +val i = fn x : u => case x of N.C x => x | D => M.A + +val toString = fn x => + case x of + C A => "C A" + | C B => "C B" + | D => "D" + +val rec page = fn x => + {cdata (toString x)}
    +
    + + Again! + + +val main : unit -> page = fn () => +
  • C A
    • +
  • C B
    • +
  • D
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdata.lac --- a/tests/cdata.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -val main : xml[Html] = diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdata.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cdata.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1 @@ +val main : xml[Html] = diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdataF.lac --- a/tests/cdataF.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val snippet = fn s => -

    {cdata s}

    - - -val main = fn () => - {snippet " diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdataF.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cdataF.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val snippet = fn s => +

    {cdata s}

    + + +val main = fn () => + {snippet " diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdataL.lac --- a/tests/cdataL.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val subpage = fn s => -

    {cdata s}

    - - -val main = fn () => -
  • Door #1
    • -
  • Door #2
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdataL.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cdataL.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val subpage = fn s => +

    {cdata s}

    + + +val main = fn () => +
  • Door #1
    • +
  • Door #2
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdatas.lac --- a/tests/cdatas.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -val main : xml[Html] = - Hi! - Bye! - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cdatas.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cdatas.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,4 @@ +val main : xml[Html] = + Hi! + Bye! + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cfold.lac --- a/tests/cfold.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -con currier = fold (fn nm => fn t => fn acc => t -> acc) {} - -con greenCurryIngredients :: {Type} = [] -con greenCurry = currier greenCurryIngredients -val greenCurry : greenCurry = {} - -con redCurryIngredients = [A = int, B = string] -con redCurry = currier redCurryIngredients -val redCurry : redCurry = fn x : int => fn y : string => {} - -con yellowCurryIngredients = [A = string, B = int, C = float] -con yellowCurry = currier yellowCurryIngredients -val yellowCurry : yellowCurry = fn x => fn y => fn z => {} - -val main = yellowCurry diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cfold.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cfold.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +con currier = fold (fn nm => fn t => fn acc => t -> acc) {} + +con greenCurryIngredients :: {Type} = [] +con greenCurry = currier greenCurryIngredients +val greenCurry : greenCurry = {} + +con redCurryIngredients = [A = int, B = string] +con redCurry = currier redCurryIngredients +val redCurry : redCurry = fn x : int => fn y : string => {} + +con yellowCurryIngredients = [A = string, B = int, C = float] +con yellowCurry = currier yellowCurryIngredients +val yellowCurry : yellowCurry = fn x => fn y => fn z => {} + +val main = yellowCurry diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cfold_disj.lac --- a/tests/cfold_disj.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -con id = fold (fn nm => fn t :: Type => fn acc => [nm] ~ acc => [nm = t] ++ acc) [] - -con idT = id [D = int, E = float] - -val idV = fn x : $idT => x.E diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cfold_disj.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cfold_disj.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,5 @@ +con id = fold (fn nm => fn t :: Type => fn acc => [nm] ~ acc => [nm = t] ++ acc) [] + +con idT = id [D = int, E = float] + +val idV = fn x : $idT => x.E diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/checkbox.lac --- a/tests/checkbox.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -val handler = fn x => - {if x.A then cdata "Yes" else cdata "No"} - - -val main = fn () => - - How about it?
    - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/checkbox.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/checkbox.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +val handler = fn x => + {if x.A then cdata "Yes" else cdata "No"} + + +val main = fn () => + + How about it?
    + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cloconv.lac --- a/tests/cloconv.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -val main = fn x : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cloconv.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cloconv.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1 @@ +val main = fn x : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/constraint.lac --- a/tests/constraint.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -signature S = sig - con nm :: Name - con r :: {Type} - - constraint [nm] ~ r -end - -structure M : S = struct - con nm = #A - con r = [B = float, C = string] - - constraint [A] ~ [B] - constraint [nm] ~ r - constraint [C] ~ [D] -end - -structure M' = struct - open M - - con combo = [nm = int] ++ r -end - -structure M' = struct - open constraints M - - con nm' = M.nm - con r' = M.r - con combo = [nm' = int] ++ r' -end - - -signature S' = sig - con r1 :: {Type} - con r2 :: {Type} - - constraint r1 ~ r2 -end - -functor F (M : S) : S' = struct - con r1 = [M.nm = int] - con r2 = M.r - - open constraints M - constraint r1 ~ r2 -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/constraint.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/constraint.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,45 @@ +signature S = sig + con nm :: Name + con r :: {Type} + + constraint [nm] ~ r +end + +structure M : S = struct + con nm = #A + con r = [B = float, C = string] + + constraint [A] ~ [B] + constraint [nm] ~ r + constraint [C] ~ [D] +end + +structure M' = struct + open M + + con combo = [nm = int] ++ r +end + +structure M' = struct + open constraints M + + con nm' = M.nm + con r' = M.r + con combo = [nm' = int] ++ r' +end + + +signature S' = sig + con r1 :: {Type} + con r2 :: {Type} + + constraint r1 ~ r2 +end + +functor F (M : S) : S' = struct + con r1 = [M.nm = int] + con r2 = M.r + + open constraints M + constraint r1 ~ r2 +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/ctuple.lac --- a/tests/ctuple.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -val page = fn p :: (Type * Type) => fn f : p.1 -> string => fn x : p.1 => - {cdata (f x)} - - -val page_string = page [(string, int)] (fn x => x) - -val main : unit -> page = fn () => - Hi - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/ctuple.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/ctuple.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +val page = fn p :: (Type * Type) => fn f : p.1 -> string => fn x : p.1 => + {cdata (f x)} + + +val page_string = page [(string, int)] (fn x => x) + +val main : unit -> page = fn () => + Hi + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/curry.lac --- a/tests/curry.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -val main = fn x : int => fn y : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/curry.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/curry.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1 @@ +val main = fn x : int => fn y : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/curry3.lac --- a/tests/curry3.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -val main = fn x : int => fn y : int => fn z : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/curry3.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/curry3.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1 @@ +val main = fn x : int => fn y : int => fn z : int => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cut.lac --- a/tests/cut.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -val r = {A = 1, B = "Hi", C = 0.0} -val rA = r -- #A - -val main : unit -> page = fn () => - {cdata rA.B} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/cut.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cut.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,6 @@ +val r = {A = 1, B = "Hi", C = 0.0} +val rA = r -- #A + +val main : unit -> page = fn () => + {cdata rA.B} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatype.lac --- a/tests/datatype.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -datatype t = A | B - -val a = A -val b = B - -datatype foo = C of t - -val c = C a - -datatype list = Nil | Cons of {Head : int, Tail : list} - -val nil = Nil -val l1 = Cons {Head = 0, Tail = nil} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatype.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/datatype.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +datatype t = A | B + +val a = A +val b = B + +datatype foo = C of t + +val c = C a + +datatype list = Nil | Cons of {Head : int, Tail : list} + +val nil = Nil +val l1 = Cons {Head = 0, Tail = nil} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeMod.lac --- a/tests/datatypeMod.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -structure M : sig datatype t = A | B end = struct - datatype t = A | B -end - -val ac = M.A - -datatype u = datatype M.t - -val ac : M.t = A -val a2 : u = ac - -structure M2 = M -structure M3 : sig datatype t = datatype M.t end = M2 -structure M4 : sig datatype t = datatype M.t end = M - -val bc : M3.t = M4.B - -structure Ma : sig type t end = M - -structure Magain : sig datatype t = A | B end = M - -val page : M.t -> page = fn x => - Hi. - - -val main : unit -> page = fn () => - Link - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeMod.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/datatypeMod.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,28 @@ +structure M : sig datatype t = A | B end = struct + datatype t = A | B +end + +val ac = M.A + +datatype u = datatype M.t + +val ac : M.t = A +val a2 : u = ac + +structure M2 = M +structure M3 : sig datatype t = datatype M.t end = M2 +structure M4 : sig datatype t = datatype M.t end = M + +val bc : M3.t = M4.B + +structure Ma : sig type t end = M + +structure Magain : sig datatype t = A | B end = M + +val page : M.t -> page = fn x => + Hi. + + +val main : unit -> page = fn () => + Link + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeP.lac --- a/tests/datatypeP.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -datatype option a = None | Some of a - -val none : option int = None -val some_1 : option int = Some 1 - -val f = fn t ::: Type => fn x : option t => - case x of None => None | Some x => Some (Some x) - -val none_again = f none -val some_1_again = f some_1 - -val show = fn t ::: Type => fn x : option t => case x of None => "None" | Some _ => "Some" - -val page = fn x => - {cdata (show x)} - - -val main : unit -> page = fn () => -
  • None
    • -
  • Some 1
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeP.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/datatypeP.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,21 @@ +datatype option a = None | Some of a + +val none : option int = None +val some_1 : option int = Some 1 + +val f = fn t ::: Type => fn x : option t => + case x of None => None | Some x => Some (Some x) + +val none_again = f none +val some_1_again = f some_1 + +val show = fn t ::: Type => fn x : option t => case x of None => "None" | Some _ => "Some" + +val page = fn x => + {cdata (show x)} + + +val main : unit -> page = fn () => +
  • None
    • +
  • Some 1
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeP2.lac --- a/tests/datatypeP2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -datatype sum a b = Left of a | Right of b - -val l : sum int string = Left 5 -val r : sum int string = Right "Hi" - -val show = fn x : sum int string => case x of Left _ => "Left _" | Right s => s - -val page = fn x => - {cdata (show x)} - - -val main : unit -> page = fn () => -
  • Left
    • -
  • Right
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/datatypeP2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/datatypeP2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +datatype sum a b = Left of a | Right of b + +val l : sum int string = Left 5 +val r : sum int string = Right "Hi" + +val show = fn x : sum int string => case x of Left _ => "Left _" | Right s => s + +val page = fn x => + {cdata (show x)} + + +val main : unit -> page = fn () => +
  • Left
    • +
  • Right
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/disjoint.lac --- a/tests/disjoint.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -con c1 = fn x :: Name => [x] ~ [A] => [x = int, A = string] -con c2 = fn x :: Name => [x] ~ [A] => [A, x] -con c3 = fn x :: Name => [A] ~ [x] => [x, A] -con c4 = fn x :: Name => [A] ~ [x] => [A, x] - -con c5 = fn r1 :: {Type} => fn r2 => r1 ~ r2 => r1 ++ r2 -con c6 = fn r1 :: {Type} => fn r2 => r2 ~ r1 => r1 ++ r2 - -con c7 = fn x :: Name => fn r => [x] ~ r => [x = int] ++ r - -val vt1 = fn x : $(c1 #B) => x.B -val vt2 = fn x : $(c1 #B) => x.A -val vt3 = fn x : $(c1 #C) => x.A -val vt4 = fn x : $(c1 #C) => x.A -(* -val vtX = fn x : $(c1 #A) => x.A -val vtX = fn x : $(c1 #A) => x.A -*) - -val v1 = fn x :: Name => fn [x] ~ [A] => fn y : {x : int, A : string} => y.x - -val vt5 = v1 [#B] {A = "Hi", B = 0} -(* -val vtX = v1 [#A] {A = "Hi", A = 0} -*) - -val v2 = fn x :: Name => fn r :: {Type} => fn y : $(c7 x r) => fn [x] ~ r => y.x -val vt6 = v2 [#A] [[B = float, C = string]] {A = 8, B = 8.0, C = "8"} - -(* -val vtX = v2 [#A] [[B = float, B = string]] {A = 8, B = 8.0, B = "8"} -val vtX = v2 [#A] [[A = float, B = string]] {A = 8, A = 8.0, B = "8"} -*) - -val main = vt6 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/disjoint.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/disjoint.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,35 @@ +con c1 = fn x :: Name => [x] ~ [A] => [x = int, A = string] +con c2 = fn x :: Name => [x] ~ [A] => [A, x] +con c3 = fn x :: Name => [A] ~ [x] => [x, A] +con c4 = fn x :: Name => [A] ~ [x] => [A, x] + +con c5 = fn r1 :: {Type} => fn r2 => r1 ~ r2 => r1 ++ r2 +con c6 = fn r1 :: {Type} => fn r2 => r2 ~ r1 => r1 ++ r2 + +con c7 = fn x :: Name => fn r => [x] ~ r => [x = int] ++ r + +val vt1 = fn x : $(c1 #B) => x.B +val vt2 = fn x : $(c1 #B) => x.A +val vt3 = fn x : $(c1 #C) => x.A +val vt4 = fn x : $(c1 #C) => x.A +(* +val vtX = fn x : $(c1 #A) => x.A +val vtX = fn x : $(c1 #A) => x.A +*) + +val v1 = fn x :: Name => fn [x] ~ [A] => fn y : {x : int, A : string} => y.x + +val vt5 = v1 [#B] {A = "Hi", B = 0} +(* +val vtX = v1 [#A] {A = "Hi", A = 0} +*) + +val v2 = fn x :: Name => fn r :: {Type} => fn y : $(c7 x r) => fn [x] ~ r => y.x +val vt6 = v2 [#A] [[B = float, C = string]] {A = 8, B = 8.0, C = "8"} + +(* +val vtX = v2 [#A] [[B = float, B = string]] {A = 8, B = 8.0, B = "8"} +val vtX = v2 [#A] [[A = float, B = string]] {A = 8, A = 8.0, B = "8"} +*) + +val main = vt6 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/eargs.lac --- a/tests/eargs.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val id1 = fn n : int => n -val id2 = fn n => id1 n - -val pair1 = fn (t1 ::: Type) (t2 ::: Type) (x1 : t1) (x2 : t2) => (x1, x2) -val pair2 = fn (t1 ::: Type) (t2 ::: Type) (x1 : t1) (x2 : t2) () => pair1 x1 x2 - -val id3 n = id2 n -val id4 n : int = id3 n -val id5 (n : int) = id4 n -val id6 (n : int) : int = id5 n - -val id1 (t ::: Type) (x : t) = x -val id2 (t ::: Type) (x : t) : t = id1 x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/eargs.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/eargs.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val id1 = fn n : int => n +val id2 = fn n => id1 n + +val pair1 = fn (t1 ::: Type) (t2 ::: Type) (x1 : t1) (x2 : t2) => (x1, x2) +val pair2 = fn (t1 ::: Type) (t2 ::: Type) (x1 : t1) (x2 : t2) () => pair1 x1 x2 + +val id3 n = id2 n +val id4 n : int = id3 n +val id5 (n : int) = id4 n +val id6 (n : int) : int = id5 n + +val id1 (t ::: Type) (x : t) = x +val id2 (t ::: Type) (x : t) : t = id1 x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/efold.lac --- a/tests/efold.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val currier : rs :: {Type} -> Cfold.currier rs = - fold [Cfold.currier] (fn nm :: Name => fn t :: Type => fn rest :: {Type} => fn acc => fn x : t => acc) {} - -val greenCurry : Cfold.greenCurry = currier [Cfold.greenCurryIngredients] -val redCurry : Cfold.redCurry = currier [Cfold.redCurryIngredients] -val yellowCurry : Cfold.yellowCurry = currier [Cfold.yellowCurryIngredients] - -val main = yellowCurry diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/efold.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/efold.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val currier : rs :: {Type} -> Cfold.currier rs = + fold [Cfold.currier] (fn nm :: Name => fn t :: Type => fn rest :: {Type} => fn acc => fn x : t => acc) {} + +val greenCurry : Cfold.greenCurry = currier [Cfold.greenCurryIngredients] +val redCurry : Cfold.redCurry = currier [Cfold.redCurryIngredients] +val yellowCurry : Cfold.yellowCurry = currier [Cfold.yellowCurryIngredients] + +val main = yellowCurry diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/equiv.lac --- a/tests/equiv.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -type t1 = {A : int, B : float} -type t2 = {B : float, A : int} -val e1 : t1 -> t2 = fn x => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/equiv.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/equiv.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,3 @@ +type t1 = {A : int, B : float} +type t2 = {B : float, A : int} +val e1 : t1 -> t2 = fn x => x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/ffi.lac --- a/tests/ffi.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -extern structure Lib : sig - type t - type u - val x : t - val y : u - val f0 : {} -> u - val f1 : t -> t - val f2 : t -> u -> t -end - -type t' = Lib.t -val x' : t' = Lib.x -val f0' = Lib.f0 -val f1' = Lib.f1 -val f2' = Lib.f2 - -structure Lib' = Lib - -type t'' = Lib'.t -val x'' : t'' = Lib'.x - -val main = f2' (f1' x') (f0' {}) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/ffi.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/ffi.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,22 @@ +extern structure Lib : sig + type t + type u + val x : t + val y : u + val f0 : {} -> u + val f1 : t -> t + val f2 : t -> u -> t +end + +type t' = Lib.t +val x' : t' = Lib.x +val f0' = Lib.f0 +val f1' = Lib.f1 +val f2' = Lib.f2 + +structure Lib' = Lib + +type t'' = Lib'.t +val x'' : t'' = Lib'.x + +val main = f2' (f1' x') (f0' {}) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/foldm.lac --- a/tests/foldm.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -con currier = fold (fn nm => fn t => fn acc => t -> acc) {} - -signature S = sig - type t - val x : t - - con rs :: {Type} - val create : currier rs -> t -end - -functor Currier (M : sig con rs :: {Type} end) : S where con rs = M.rs = struct - val currier : rs :: {Type} -> currier rs = - fold [currier] (fn nm :: Name => fn t :: Type => fn rest :: {Type} => fn acc => fn x : t => acc) {} - - type t = currier M.rs - val x = currier [M.rs] - - con rs = M.rs - val create : t -> t = fn x => x -end - -structure ChefsSpecial = Currier(struct - con rs = [A = int, B = float] -end) - -val main = ChefsSpecial.x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/foldm.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/foldm.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,26 @@ +con currier = fold (fn nm => fn t => fn acc => t -> acc) {} + +signature S = sig + type t + val x : t + + con rs :: {Type} + val create : currier rs -> t +end + +functor Currier (M : sig con rs :: {Type} end) : S where con rs = M.rs = struct + val currier : rs :: {Type} -> currier rs = + fold [currier] (fn nm :: Name => fn t :: Type => fn rest :: {Type} => fn acc => fn x : t => acc) {} + + type t = currier M.rs + val x = currier [M.rs] + + con rs = M.rs + val create : t -> t = fn x => x +end + +structure ChefsSpecial = Currier(struct + con rs = [A = int, B = float] +end) + +val main = ChefsSpecial.x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form.lac --- a/tests/form.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val handler = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Word: {cdata r.Word}
    • - - -val main : unit -> page = fn () => - - Name:
    - Word:
    - - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/form.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val handler = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Word: {cdata r.Word}
    • + + +val main : unit -> page = fn () => + + Name:
    + Word:
    + + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form2.lac --- a/tests/form2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -val handler1 = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Word: {cdata r.Word}
    • - - -val handler2 = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Ward: {cdata r.Ward}
    • - - -val main : unit -> page = fn () => - - Name:
    - Word:
    - - -     - - - Name:
    - Word:
    - - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/form2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,25 @@ +val handler1 = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Word: {cdata r.Word}
    • + + +val handler2 = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Ward: {cdata r.Ward}
    • + + +val main : unit -> page = fn () => + + Name:
    + Word:
    + + +     + + + Name:
    + Word:
    + + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form3.lac --- a/tests/form3.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -val handler1 = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Word: {cdata r.Word}
    • - - -val handler2 = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Ward: {cdata r.Ward}
    • - - -val handler3 = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Ward: {cdata r.Ward}
    • -
  • Words: {cdata r.Words}
    • - - -val main : unit -> page = fn () => - - Name:
    - Word:
    - - -     - - - Name:
    - Word:
    - - -     - - - Name:
    - Ward:
    - Words:
    - - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/form3.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/form3.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,39 @@ +val handler1 = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Word: {cdata r.Word}
    • + + +val handler2 = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Ward: {cdata r.Ward}
    • + + +val handler3 = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Ward: {cdata r.Ward}
    • +
  • Words: {cdata r.Words}
    • + + +val main : unit -> page = fn () => + + Name:
    + Word:
    + + +     + + + Name:
    + Word:
    + + +     + + + Name:
    + Ward:
    + Words:
    + + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/functor.lac --- a/tests/functor.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -signature S = sig - type t - val z : t - val s : t -> t -end - -signature T = sig - type t - val three : t -end - -functor F (M : S) : T where type t = M.t = struct - type t = M.t - val three = M.s (M.s (M.s M.z)) -end - - -structure O = F (struct - type t = int - val z = 0 - val s = fn x : t => x -end) -val three : int = O.three - -structure S = struct - type t = int - val z = 0 - val s = fn x : t => x -end -structure SO = F (S) -val three : int = SO.three - -structure SS : S = S -structure SSO = F (SS) -val three : SS.t = SSO.three - -val main = three diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/functor.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/functor.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,37 @@ +signature S = sig + type t + val z : t + val s : t -> t +end + +signature T = sig + type t + val three : t +end + +functor F (M : S) : T where type t = M.t = struct + type t = M.t + val three = M.s (M.s (M.s M.z)) +end + + +structure O = F (struct + type t = int + val z = 0 + val s = fn x : t => x +end) +val three : int = O.three + +structure S = struct + type t = int + val z = 0 + val s = fn x : t => x +end +structure SO = F (S) +val three : int = SO.three + +structure SS : S = S +structure SSO = F (SS) +val three : SS.t = SSO.three + +val main = three diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/gform.lac --- a/tests/gform.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -con stringify = fold (fn nm :: Name => fn u :: Unit => fn t :: {Type} => [nm = string] ++ t) [] - -signature S = sig - con rs :: {Unit} -end - -signature S' = sig - con rs :: {Unit} - - val handler : $(stringify rs) -> page - val page : unit -> page -end - -functor F (M : S) : S' where con rs = M.rs = struct - con rs = M.rs - - val handler = fn x : $(stringify M.rs) => - {fold [fn rs :: {Unit} => $(stringify rs) -> xml body [] []] - (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => - fn f : $(stringify rest) -> xml body [] [] => - fn x : $(stringify ([nm] ++ rest)) => -
  • {cdata x.nm}
    • {f (x -- nm)}) - (fn x => ) - [M.rs] x} - - - val page = fn () => - - {fold [fn rs :: {Unit} => xml lform [] (stringify rs)] - (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => - fn frag : xml lform [] (stringify rest) => -
    • {useMore frag}    ) - - [rs]} - - -     - -end - -structure M = F(struct - con rs = [A, B, C] -end) - -open M - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/gform.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/gform.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,46 @@ +con stringify = fold (fn nm :: Name => fn u :: Unit => fn t :: {Type} => [nm = string] ++ t) [] + +signature S = sig + con rs :: {Unit} +end + +signature S' = sig + con rs :: {Unit} + + val handler : $(stringify rs) -> page + val page : unit -> page +end + +functor F (M : S) : S' where con rs = M.rs = struct + con rs = M.rs + + val handler = fn x : $(stringify M.rs) => + {fold [fn rs :: {Unit} => $(stringify rs) -> xml body [] []] + (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => + fn f : $(stringify rest) -> xml body [] [] => + fn x : $(stringify ([nm] ++ rest)) => +
  • {cdata x.nm}
    • {f (x -- nm)}) + (fn x => ) + [M.rs] x} + + + val page = fn () => + + {fold [fn rs :: {Unit} => xml lform [] (stringify rs)] + (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => + fn frag : xml lform [] (stringify rest) => +
    • {useMore frag}    ) + + [rs]} + + +     + +end + +structure M = F(struct + con rs = [A, B, C] +end) + +open M + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/gformText.lac --- a/tests/gformText.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -con stringify = fold (fn nm :: Name => fn u :: Unit => fn t :: {Type} => [nm = string] ++ t) [] - -signature S = sig - con rs :: {Unit} - val names : $(stringify rs) -end - -signature S' = sig - con rs :: {Unit} - - val handler : $(stringify rs) -> page - val page : unit -> page -end - -functor F (M : S) : S' where con rs = M.rs = struct - con rs = M.rs - - val handler = fn x : $(stringify M.rs) => - {fold [fn rs :: {Unit} => $(stringify rs) -> $(stringify rs) -> xml body [] []] - (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => - fn f : $(stringify rest) -> $(stringify rest) -> xml body [] [] => - fn names : $(stringify ([nm] ++ rest)) => - fn x : $(stringify ([nm] ++ rest)) => -
  • {cdata names.nm}: {cdata x.nm}
    • {f (names -- nm) (x -- nm)}) - (fn names => fn x => ) - [M.rs] M.names x} - - - val page = fn () => - - {fold [fn rs :: {Unit} => xml lform [] (stringify rs)] - (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => - fn frag : xml lform [] (stringify rest) => -
    • {useMore frag}    ) - - [rs]} - - -     - -end - -structure M = F(struct - con rs = [A, B, C] - - val names = {A = "A", B = "B", C = "C"} -end) - -open M - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/gformText.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/gformText.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,50 @@ +con stringify = fold (fn nm :: Name => fn u :: Unit => fn t :: {Type} => [nm = string] ++ t) [] + +signature S = sig + con rs :: {Unit} + val names : $(stringify rs) +end + +signature S' = sig + con rs :: {Unit} + + val handler : $(stringify rs) -> page + val page : unit -> page +end + +functor F (M : S) : S' where con rs = M.rs = struct + con rs = M.rs + + val handler = fn x : $(stringify M.rs) => + {fold [fn rs :: {Unit} => $(stringify rs) -> $(stringify rs) -> xml body [] []] + (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => + fn f : $(stringify rest) -> $(stringify rest) -> xml body [] [] => + fn names : $(stringify ([nm] ++ rest)) => + fn x : $(stringify ([nm] ++ rest)) => +
  • {cdata names.nm}: {cdata x.nm}
    • {f (names -- nm) (x -- nm)}) + (fn names => fn x => ) + [M.rs] M.names x} + + + val page = fn () => + + {fold [fn rs :: {Unit} => xml lform [] (stringify rs)] + (fn nm :: Name => fn u :: Unit => fn rest :: {Unit} => + fn frag : xml lform [] (stringify rest) => +
    • {useMore frag}    ) + + [rs]} + + +     + +end + +structure M = F(struct + con rs = [A, B, C] + + val names = {A = "A", B = "B", C = "C"} +end) + +open M + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/group_by.lac --- a/tests/group_by.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT * FROM t1 GROUP BY t1.B) -val q2 = (SELECT * FROM t1, t2 GROUP BY t1.B, t2.D, t1.A) - -val q3 = (SELECT * FROM t1 WHERE t1.A = 0 GROUP BY t1.B) -val q4 = (SELECT * FROM t1 WHERE t1.A = 0 GROUP BY t1.C HAVING t1.C < 0.2) - -val q5 = (SELECT t1.A, t2.D FROM t1, t2 GROUP BY t2.D, t1.A) -val q6 = (SELECT t1.A, t2.D FROM t1, t2 WHERE t1.C = 0.0 GROUP BY t2.D, t1.A HAVING t1.A = t1.A AND t2.D = 17) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/group_by.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/group_by.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,11 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT * FROM t1 GROUP BY t1.B) +val q2 = (SELECT * FROM t1, t2 GROUP BY t1.B, t2.D, t1.A) + +val q3 = (SELECT * FROM t1 WHERE t1.A = 0 GROUP BY t1.B) +val q4 = (SELECT * FROM t1 WHERE t1.A = 0 GROUP BY t1.C HAVING t1.C < 0.2) + +val q5 = (SELECT t1.A, t2.D FROM t1, t2 GROUP BY t2.D, t1.A) +val q6 = (SELECT t1.A, t2.D FROM t1, t2 WHERE t1.C = 0.0 GROUP BY t2.D, t1.A HAVING t1.A = t1.A AND t2.D = 17) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/html.lac --- a/tests/html.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -val main = - - Hello World! - - - - Hello World! - - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/html.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/html.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +val main = + + Hello World! + + + + Hello World! + + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/html_fn.lac --- a/tests/html_fn.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -val main : unit -> page = fn () => - - Hello World! - - - - Hello World! - - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/html_fn.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/html_fn.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +val main : unit -> page = fn () => + + Hello World! + + + + Hello World! + + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/impl.lac --- a/tests/impl.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -val id = fn t :: Type => fn x : t => x -val id_self = id [t :: Type -> t -> t] id - -val idi = fn t ::: Type => fn x : t => x -val idi_self = idi idi - -val picker = fn na :: Name => fn a ::: Type => fn nb :: Name => fn b ::: Type => fn fs ::: {Type} => - fn r : $([na = a, nb = b] ++ fs) => {na = r.na, nb = r.nb} -val getem = picker [#A] [#C] {A = 0, B = 1.0, C = "hi", D = {}} -val getem2 = picker [#A] [_] {A = 0, B = 1.0, C = "hi", D = {}} -val getem3 = picker [#A] [_::Name] {A = 0, B = 1.0, C = "hi", D = {}} - -val picker_ohmy = fn na ::: Name => fn a ::: Type => fn nb ::: Name => fn b ::: Type => fn fs ::: {Type} => - fn r : $([na = a, nb = b] ++ fs) => {na = r.na, nb = r.nb} -val getem_ohmy = picker_ohmy {A = 0, B = 1.0, C = "hi", D = {}} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/impl.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/impl.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +val id = fn t :: Type => fn x : t => x +val id_self = id [t :: Type -> t -> t] id + +val idi = fn t ::: Type => fn x : t => x +val idi_self = idi idi + +val picker = fn na :: Name => fn a ::: Type => fn nb :: Name => fn b ::: Type => fn fs ::: {Type} => + fn r : $([na = a, nb = b] ++ fs) => {na = r.na, nb = r.nb} +val getem = picker [#A] [#C] {A = 0, B = 1.0, C = "hi", D = {}} +val getem2 = picker [#A] [_] {A = 0, B = 1.0, C = "hi", D = {}} +val getem3 = picker [#A] [_::Name] {A = 0, B = 1.0, C = "hi", D = {}} + +val picker_ohmy = fn na ::: Name => fn a ::: Type => fn nb ::: Name => fn b ::: Type => fn fs ::: {Type} => + fn r : $([na = a, nb = b] ++ fs) => {na = r.na, nb = r.nb} +val getem_ohmy = picker_ohmy {A = 0, B = 1.0, C = "hi", D = {}} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/include.lac --- a/tests/include.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -signature S = sig - type t - val x : t -end - -signature S' = sig - include S - val y : t -end - -signature S'' = sig - type u - include S' where type t = int - type v -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/include.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/include.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +signature S = sig + type t + val x : t +end + +signature S' = sig + include S + val y : t +end + +signature S'' = sig + type u + include S' where type t = int + type v +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/lexerr.lac --- a/tests/lexerr.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -type t = int -type q = int -type u = inot diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/lexerr.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/lexerr.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,3 @@ +type t = int +type q = int +type u = inot diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/lexerrS.lac --- a/tests/lexerrS.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -sig -type t = int -type q = int -type u = inot diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/lexerrS.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/lexerrS.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,4 @@ +sig +type t = int +type q = int +type u = inot diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/limit.lac --- a/tests/limit.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -table t : {A : int, B : string, C : float} - -val q1 = (SELECT * FROM t LIMIT 42) -val q2 = fn n => (SELECT * FROM t LIMIT {n}) - -val q3 = (SELECT * FROM t OFFSET 3) -val q4 = fn n => fn m => (SELECT * FROM t LIMIT {n} OFFSET {m}) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/limit.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/limit.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,7 @@ +table t : {A : int, B : string, C : float} + +val q1 = (SELECT * FROM t LIMIT 42) +val q2 = fn n => (SELECT * FROM t LIMIT {n}) + +val q3 = (SELECT * FROM t OFFSET 3) +val q4 = fn n => fn m => (SELECT * FROM t LIMIT {n} OFFSET {m}) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/link.lac --- a/tests/link.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -val ancillary = fn () => - Welcome to the ancillary page! - - -val main : unit -> page = fn () => - Enter the unknown! - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/link.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/link.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,7 @@ +val ancillary = fn () => + Welcome to the ancillary page! + + +val main : unit -> page = fn () => + Enter the unknown! + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/links.lac --- a/tests/links.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -val pC : xhtml = -

    Page C

    - - -val pB : xhtml = -

    Page B

    - -
  • C
    • - - -val pA : xhtml = -

    Page A

    - -
  • B
    • -
  • C
    • - - -val main : unit -> xhtml = fn () => -

    Main

    - -
  • A
    • -
  • B
    • -
  • C
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/links.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/links.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,24 @@ +val pC : xhtml = +

    Page C

    + + +val pB : xhtml = +

    Page B

    + +
  • C
    • + + +val pA : xhtml = +

    Page A

    + +
  • B
    • +
  • C
    • + + +val main : unit -> xhtml = fn () => +

    Main

    + +
  • A
    • +
  • B
    • +
  • C
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/linksF.lac --- a/tests/linksF.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -val pC : unit -> xhtml = fn () => -

    Page C

    - - -val pB : unit -> xhtml = fn () => -

    Page B

    - -
  • C
    • - - -val pA : unit -> xhtml = fn () => -

    Page A

    - -
  • B
    • -
  • C
    • - - -val main : unit -> xhtml = fn () => -

    Main

    - -
  • A
    • -
  • B
    • -
  • C
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/linksF.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/linksF.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,24 @@ +val pC : unit -> xhtml = fn () => +

    Page C

    + + +val pB : unit -> xhtml = fn () => +

    Page B

    + +
  • C
    • + + +val pA : unit -> xhtml = fn () => +

    Page A

    + +
  • B
    • +
  • C
    • + + +val main : unit -> xhtml = fn () => +

    Main

    + +
  • A
    • +
  • B
    • +
  • C
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/list.lac --- a/tests/list.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ -datatype list a = Nil | Cons of a * list a - -val isNil = fn t ::: Type => fn ls : list t => - case ls of Nil => True | _ => False - -val show = fn b => if b then "True" else "False" - -val rec delist : list string -> xml body [] [] = fn x => - case x of - Nil => Nil - | Cons (h, t) => {cdata h} :: {delist t} - -val main : unit -> page = fn () => - {cdata (show (isNil (Nil : list bool)))}, - {cdata (show (isNil (Cons (1, Nil))))}, - {cdata (show (isNil (Cons ("A", Cons ("B", Nil)))))} - -

    {delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}

    - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/list.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/list.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,19 @@ +datatype list a = Nil | Cons of a * list a + +val isNil = fn t ::: Type => fn ls : list t => + case ls of Nil => True | _ => False + +val show = fn b => if b then "True" else "False" + +val rec delist : list string -> xml body [] [] = fn x => + case x of + Nil => Nil + | Cons (h, t) => {cdata h} :: {delist t} + +val main : unit -> page = fn () => + {cdata (show (isNil (Nil : list bool)))}, + {cdata (show (isNil (Cons (1, Nil))))}, + {cdata (show (isNil (Cons ("A", Cons ("B", Nil)))))} + +

    {delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}

    + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modnested.lac --- a/tests/modnested.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -signature S = sig - type t - val x : t - - structure Q : sig - type q - val y : q - - structure V : sig - type v - end - end -end - -structure S = struct - type t = int - val x = 0 - - structure Q = struct - type q = float - val y = 0.0 - - structure V = struct - type v = string - val hi = "Hi" - end - end -end - -structure S1 = S -structure S2 : S = S -structure S3 = S2 - -val main = S3.Q.y diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modnested.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/modnested.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,34 @@ +signature S = sig + type t + val x : t + + structure Q : sig + type q + val y : q + + structure V : sig + type v + end + end +end + +structure S = struct + type t = int + val x = 0 + + structure Q = struct + type q = float + val y = 0.0 + + structure V = struct + type v = string + val hi = "Hi" + end + end +end + +structure S1 = S +structure S2 : S = S +structure S3 = S2 + +val main = S3.Q.y diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modproj.lac --- a/tests/modproj.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ -signature S1 = sig - type t - val zero : t -end -signature S2 = sig - type t = int - val zero : t -end -structure S = struct - type t = int - val zero = 0 -end -structure S1 : S1 = S -structure S2 : S2 = S - -type t = S1.t -val zero : t = S1.zero - -type t = S2.t -val zero : int = S2.zero - -structure T = S1 -val main : S1.t = T.zero diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modproj.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/modproj.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,23 @@ +signature S1 = sig + type t + val zero : t +end +signature S2 = sig + type t = int + val zero : t +end +structure S = struct + type t = int + val zero = 0 +end +structure S1 : S1 = S +structure S2 : S2 = S + +type t = S1.t +val zero : t = S1.zero + +type t = S2.t +val zero : int = S2.zero + +structure T = S1 +val main : S1.t = T.zero diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modules.lac --- a/tests/modules.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -signature A = sig end -structure A = struct end -structure Ao : A = A - - -structure B = struct - type t = int -end -structure Bo0 : sig end = B -structure BoA : A = B - -signature B1 = sig - type t -end -structure Bo1 : B1 = B -(*structure AoB1 : B1 = A*) - -signature B2 = sig - type t = int -end -structure Bo2 : B2 = B - - -structure C = struct - type t = float -end -structure CoB1 : B1 = C -(*structure CoB2 : B2 = C*) - - -signature NAT = sig - type t - val zero : t -end -structure Nat : NAT = struct - type t = int - val zero = 0 -end -(*structure NotNat : NAT = struct - type t = int - val zero = 0.0 -end*) -(*structure NotNat : NAT = struct - val zero = 0 -end*) - - -signature WOBBLE = sig - type t - type s -end -structure Wobble1 = struct - type t = int - type s = float -end -structure Wobble2 = struct - type s = int - type t = float -end - - -structure N = struct - type t = string - structure N2 = struct - type t = int - val zero = 0 - end - val x = "Hi" -end -signature N = sig - structure N2 : NAT - type t - val x : t -end -structure No : N = N diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/modules.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/modules.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,75 @@ +signature A = sig end +structure A = struct end +structure Ao : A = A + + +structure B = struct + type t = int +end +structure Bo0 : sig end = B +structure BoA : A = B + +signature B1 = sig + type t +end +structure Bo1 : B1 = B +(*structure AoB1 : B1 = A*) + +signature B2 = sig + type t = int +end +structure Bo2 : B2 = B + + +structure C = struct + type t = float +end +structure CoB1 : B1 = C +(*structure CoB2 : B2 = C*) + + +signature NAT = sig + type t + val zero : t +end +structure Nat : NAT = struct + type t = int + val zero = 0 +end +(*structure NotNat : NAT = struct + type t = int + val zero = 0.0 +end*) +(*structure NotNat : NAT = struct + val zero = 0 +end*) + + +signature WOBBLE = sig + type t + type s +end +structure Wobble1 = struct + type t = int + type s = float +end +structure Wobble2 = struct + type s = int + type t = float +end + + +structure N = struct + type t = string + structure N2 = struct + type t = int + val zero = 0 + end + val x = "Hi" +end +signature N = sig + structure N2 : NAT + type t + val x : t +end +structure No : N = N diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/open.lac --- a/tests/open.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -structure S = struct - type t = int - val x = 0 - - structure S' : sig type u val y : t end = struct - type u = t - val y = x - end - - signature Sig = sig - type t - val x : t - end -end - -open S.S' -open S -open S' - -structure S' : Sig = S diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/open.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/open.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,20 @@ +structure S = struct + type t = int + val x = 0 + + structure S' : sig type u val y : t end = struct + type u = t + val y = x + end + + signature Sig = sig + type t + val x : t + end +end + +open S.S' +open S +open S' + +structure S' : Sig = S diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/open_functor.lac --- a/tests/open_functor.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -signature S = sig - type t - val x : t -end - -functor F (M : S) : S where type t = M.t = struct - type t = M.t - val x = M.x -end - -structure M = F(struct - type t = int - val x = 0 -end) - -open M diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/open_functor.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/open_functor.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,16 @@ +signature S = sig + type t + val x : t +end + +functor F (M : S) : S where type t = M.t = struct + type t = M.t + val x = M.x +end + +structure M = F(struct + type t = int + val x = 0 +end) + +open M diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/option.lac --- a/tests/option.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -datatype option a = None | Some of a - -val none_Hi : option string = None -val some_Hi = Some "Hi" -val none_some_Hi : option (option string) = None -val some_some_Hi = Some some_Hi - -val show = fn x => case x of None => "None" | Some x => x - -val show2 = fn x => case x of None => "None'" | Some x => show x - -val page = fn x => - {cdata (show x)} - - -val page2 = fn x => - {cdata (show2 x)} - - -val main : unit -> page = fn () => -
  • None1
    • -
  • Some1
    • -
  • None2
    • -
  • Some2
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/option.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/option.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,25 @@ +datatype option a = None | Some of a + +val none_Hi : option string = None +val some_Hi = Some "Hi" +val none_some_Hi : option (option string) = None +val some_some_Hi = Some some_Hi + +val show = fn x => case x of None => "None" | Some x => x + +val show2 = fn x => case x of None => "None'" | Some x => show x + +val page = fn x => + {cdata (show x)} + + +val page2 = fn x => + {cdata (show2 x)} + + +val main : unit -> page = fn () => +
  • None1
    • +
  • Some1
    • +
  • None2
    • +
  • Some2
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/order_by.lac --- a/tests/order_by.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT * FROM t1 ORDER BY t1.A, t1.B) -val q2 = (SELECT * FROM t1 GROUP BY t1.A ORDER BY t1.A, t1.B) -val q3 = (SELECT t1.B FROM t1 - UNION SELECT t1.B FROM t1 - ORDER BY t1.B) - -val q4 = (SELECT t1.A, t2.D, t1.A < t2.D AS Lt - FROM t1, t2 - ORDER BY Lt) -val q5 = (SELECT t1.A, t2.D, t1.A < t2.D AS Lt - FROM t1, t2 - ORDER BY t1.A, Lt, t2.D) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/order_by.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/order_by.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,15 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT * FROM t1 ORDER BY t1.A, t1.B) +val q2 = (SELECT * FROM t1 GROUP BY t1.A ORDER BY t1.A, t1.B) +val q3 = (SELECT t1.B FROM t1 + UNION SELECT t1.B FROM t1 + ORDER BY t1.B) + +val q4 = (SELECT t1.A, t2.D, t1.A < t2.D AS Lt + FROM t1, t2 + ORDER BY Lt) +val q5 = (SELECT t1.A, t2.D, t1.A < t2.D AS Lt + FROM t1, t2 + ORDER BY t1.A, Lt, t2.D) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/pass.lac --- a/tests/pass.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val handler = fn r => -
  • Name: {cdata r.Nam}
    • -
  • Password: {cdata r.Word}
    • - - -val main : unit -> page = fn () => - - Name:
    - Password:
    - - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/pass.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/pass.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val handler = fn r => +
  • Name: {cdata r.Nam}
    • +
  • Password: {cdata r.Word}
    • + + +val main : unit -> page = fn () => + + Name:
    + Password:
    + + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/pcase.lac --- a/tests/pcase.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -val flip = fn x : int => case x of 0 => 1 | _ => 0 - -val zero = flip 1 -val one = flip 0 - -val flipS = fn x : string => case x of "" => "Hello world!" | _ => "" - -val s1 = flipS "" -val s2 = flipS "Boop" diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/pcase.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/pcase.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +val flip = fn x : int => case x of 0 => 1 | _ => 0 + +val zero = flip 1 +val one = flip 0 + +val flipS = fn x : string => case x of "" => "Hello world!" | _ => "" + +val s1 = flipS "" +val s2 = flipS "Boop" diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink.lac --- a/tests/plink.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val pA = fn size => - Hello World! - - -val main : unit -> page = fn () => -
  • Size 5
    • -
  • Size 10
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/plink.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val pA = fn size => + Hello World! + + +val main : unit -> page = fn () => +
  • Size 5
    • +
  • Size 10
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink2.lac --- a/tests/plink2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val pA : int -> int -> page = fn size1 => fn size2 => - Hello World! - - -val main : unit -> page = fn () => -
  • Size 5
    • -
  • Size 10
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/plink2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val pA : int -> int -> page = fn size1 => fn size2 => + Hello World! + + +val main : unit -> page = fn () => +
  • Size 5
    • +
  • Size 10
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink3.lac --- a/tests/plink3.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -val pA = fn size1 => fn size2 => fn size3 => -

    Hello World!

    - -

    Epilogue

    - - -val main = fn () => -
  • Size 5
    • -
  • Size 10
    • - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/plink3.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/plink3.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +val pA = fn size1 => fn size2 => fn size3 => +

    Hello World!

    + +

    Epilogue

    + + +val main = fn () => +
  • Size 5
    • +
  • Size 10
    • + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/prim.lac --- a/tests/prim.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -val zero = 0 -val pi = 3.14159 -val welcome = "Hello world!" diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/prim.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/prim.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,3 @@ +val zero = 0 +val pi = 3.14159 +val welcome = "Hello world!" diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/query.lac --- a/tests/query.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -datatype list a = Nil | Cons of a * list a - -val q1 = (SELECT * FROM t1) -val r1 : transaction (list {A : int, B : string, C : float}) = - query q1 - (fn fs _ acc => return (Cons (fs.T1, acc))) - Nil - -val r2 : transaction int = - ls <- r1; - return (case ls of - Nil => 0 - | Cons ({A = a, ...}, _) => a) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/query.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/query.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,16 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +datatype list a = Nil | Cons of a * list a + +val q1 = (SELECT * FROM t1) +val r1 : transaction (list {A : int, B : string, C : float}) = + query q1 + (fn fs _ acc => return (Cons (fs.T1, acc))) + Nil + +val r2 : transaction int = + ls <- r1; + return (case ls of + Nil => 0 + | Cons ({A = a, ...}, _) => a) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/radio.lac --- a/tests/radio.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val handler = fn x => - You entered: {cdata x.A} - - -val main = fn () => - - -
  • A
    • -
  • B
    • - - -     - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/radio.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/radio.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val handler = fn x => + You entered: {cdata x.A} + + +val main = fn () => + + +
  • A
    • +
  • B
    • + + +     + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec.lac --- a/tests/rec.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -val rec main = fn () => - Ride again! - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rec.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,3 @@ +val rec main = fn () => + Ride again! + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec2.lac --- a/tests/rec2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -val rec main = fn () => - See another page - - -and aux = fn () => - Back to square one - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rec2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,7 @@ +val rec main = fn () => + See another page + + +and aux = fn () => + Back to square one + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec3.lac --- a/tests/rec3.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val rec main = fn () => - See another page - - -and aux = fn () => -

    The Main Event

    - - {auxer ()} - - -and auxer = fn () => - Back to square one - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rec3.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rec3.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val rec main = fn () => + See another page + + +and aux = fn () => +

    The Main Event

    + + {auxer ()} + + +and auxer = fn () => + Back to square one + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recBad.lac --- a/tests/recBad.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -datatype list a = Nil | Cons of a * list a - -fun append (t ::: Type) (ls1 : list t) (ls2 : list t) : list t = - case ls1 of - Nil => ls2 - | Cons (h, t) => Cons (h, append t ls2) - -(*val rec ones : list int = Cons (1, ones)*) -val rec ones = fn () => Cons (1, ones ()) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recBad.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recBad.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +datatype list a = Nil | Cons of a * list a + +fun append (t ::: Type) (ls1 : list t) (ls2 : list t) : list t = + case ls1 of + Nil => ls2 + | Cons (h, t) => Cons (h, append t ls2) + +(*val rec ones : list int = Cons (1, ones)*) +val rec ones = fn () => Cons (1, ones ()) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal.lac --- a/tests/recReal.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -val rec endlessList = fn () => -
  • Buy eggs.
    • - {endlessList ()} - - -val main = fn () => - {endlessList ()} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,8 @@ +val rec endlessList = fn () => +
  • Buy eggs.
    • + {endlessList ()} + + +val main = fn () => + {endlessList ()} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal2.lac --- a/tests/recReal2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val rec endlessList1 = fn () => -
  • Buy eggs.
    • - {endlessList2 ()} - - -and endlessList2 = fn () => -
  • Buy milk.
    • - {endlessList1 ()} - - -val main = fn () => - {endlessList1 ()} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val rec endlessList1 = fn () => +
  • Buy eggs.
    • + {endlessList2 ()} + + +and endlessList2 = fn () => +
  • Buy milk.
    • + {endlessList1 ()} + + +val main = fn () => + {endlessList1 ()} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal3.lac --- a/tests/recReal3.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -val rec endlessList1 = fn () => -
  • Buy eggs.
    • - {endlessList2 ()} - - -and endlessList2 = fn () => -
  • Buy milk.
    • - {endlessList1 ()} - {endlessList3 ()} - - -and endlessList3 = fn () => -
  • Buy goat.
    • - - -val main = fn () => - {endlessList1 ()} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/recReal3.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal3.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,18 @@ +val rec endlessList1 = fn () => +
  • Buy eggs.
    • + {endlessList2 ()} + + +and endlessList2 = fn () => +
  • Buy milk.
    • + {endlessList1 ()} + {endlessList3 ()} + + +and endlessList3 = fn () => +
  • Buy goat.
    • + + +val main = fn () => + {endlessList1 ()} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/record_page.lac --- a/tests/record_page.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -type t = {A : string, B : {C : string, D : string}} - -val page = fn x : t => - {cdata x.A},{cdata x.B.C},{cdata x.B.D} - - -val main : unit -> page = fn () => -
  • First
    • -
  • Second
    • - \ No newline at end of file diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/record_page.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/record_page.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +type t = {A : string, B : {C : string, D : string}} + +val page = fn x : t => + {cdata x.A},{cdata x.B.C},{cdata x.B.D} + + +val main : unit -> page = fn () => +
  • First
    • +
  • Second
    • + \ No newline at end of file diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/reduce.lac --- a/tests/reduce.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -con c1 = int -con c2 = (fn t :: Type => t) int - -con id = fn t :: Type => t -con c3 = id int - -con fst = fn t1 :: Type => fn t2 :: Type => t1 -con c4 = fst int string - -con snd = fn t1 :: Type => fn t2 :: Type => t2 -con c5 = snd int string - -con apply = fn f :: Type -> Type => fn t :: Type => f t -con c6 = apply id int -con c7 = apply (fst int) string - -val tickle = fn n :: Name => fn t :: Type => fn fs :: {Type} => - fn x : $([n = t] ++ fs) => x -val tickleA = tickle[#A][int][[B = string]] -val test_tickleA = tickleA {A = 6, B = "13"} - -val grab = fn n :: Name => fn t ::: Type => fn fs ::: {Type} => - fn x : $([n = t] ++ fs) => x.n -val test_grab1 = grab[#A] {A = 6, B = "13"} -val test_grab2 = grab[#B] {A = 6, B = "13"} - -val main = {A = test_grab1, B = test_grab2} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/reduce.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/reduce.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,27 @@ +con c1 = int +con c2 = (fn t :: Type => t) int + +con id = fn t :: Type => t +con c3 = id int + +con fst = fn t1 :: Type => fn t2 :: Type => t1 +con c4 = fst int string + +con snd = fn t1 :: Type => fn t2 :: Type => t2 +con c5 = snd int string + +con apply = fn f :: Type -> Type => fn t :: Type => f t +con c6 = apply id int +con c7 = apply (fst int) string + +val tickle = fn n :: Name => fn t :: Type => fn fs :: {Type} => + fn x : $([n = t] ++ fs) => x +val tickleA = tickle[#A][int][[B = string]] +val test_tickleA = tickleA {A = 6, B = "13"} + +val grab = fn n :: Name => fn t ::: Type => fn fs ::: {Type} => + fn x : $([n = t] ++ fs) => x.n +val test_grab1 = grab[#A] {A = 6, B = "13"} +val test_grab2 = grab[#B] {A = 6, B = "13"} + +val main = {A = test_grab1, B = test_grab2} diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/relops.lac --- a/tests/relops.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT * FROM t1 - UNION SELECT * FROM t1) -val q2 = (SELECT t1.A, t1.B FROM t1 WHERE t1.A = 0 - INTERSECT SELECT t1.B, t1.A FROM t1 WHERE t1.B = t1.B) -val q3 = (SELECT t1.A, t1.B, t1.C FROM t1 WHERE t1.A = 0 - INTERSECT SELECT * FROM t1 WHERE t1.B = 'Hello world!' - EXCEPT SELECT * FROM t1 WHERE t1.A < t1.A) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/relops.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/relops.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT * FROM t1 + UNION SELECT * FROM t1) +val q2 = (SELECT t1.A, t1.B FROM t1 WHERE t1.A = 0 + INTERSECT SELECT t1.B, t1.A FROM t1 WHERE t1.B = t1.B) +val q3 = (SELECT t1.A, t1.B, t1.C FROM t1 WHERE t1.A = 0 + INTERSECT SELECT * FROM t1 WHERE t1.B = 'Hello world!' + EXCEPT SELECT * FROM t1 WHERE t1.A < t1.A) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rpat.lac --- a/tests/rpat.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val f = fn x : {A : int} => case x of {A = _} => 0 -val f = fn x : {A : int} => case x of {A = _, ...} => 0 -val f = fn x : {A : int, B : int} => case x of {A = _, ...} => 0 -val f = fn x : {A : int, B : int} => case x of {A = 1, B = 2} => 0 | {A = _, ...} => 1 - -datatype t = A | B - -val f = fn x => case x of {A = A, B = 2} => 0 | {A = A, ...} => 0 | {A = B, ...} => 0 - -val f = fn x => case x of {A = {A = A, ...}, B = B} => 0 - | {B = A, ...} => 1 - | {A = {A = B, B = A}, B = B} => 2 - | {A = {A = B, B = B}, B = B} => 3 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/rpat.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rpat.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val f = fn x : {A : int} => case x of {A = _} => 0 +val f = fn x : {A : int} => case x of {A = _, ...} => 0 +val f = fn x : {A : int, B : int} => case x of {A = _, ...} => 0 +val f = fn x : {A : int, B : int} => case x of {A = 1, B = 2} => 0 | {A = _, ...} => 1 + +datatype t = A | B + +val f = fn x => case x of {A = A, B = 2} => 0 | {A = A, ...} => 0 | {A = B, ...} => 0 + +val f = fn x => case x of {A = {A = A, ...}, B = B} => 0 + | {B = A, ...} => 1 + | {A = {A = B, B = A}, B = B} => 2 + | {A = {A = B, B = B}, B = B} => 3 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/select.lac --- a/tests/select.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val handler = fn x => - You entered: {cdata x.A} - - -val main = fn () => - - - A - B - - - - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/select.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/select.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val handler = fn x => + You entered: {cdata x.A} + + +val main = fn () => + + + A + B + + + + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/selexp.lac --- a/tests/selexp.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT 0 AS Zero FROM t1) -val q2 = (SELECT t1.A < t2.D AS Lt FROM t1, t2) -val q3 = (SELECT t1.A < t2.D AS Lt, t1.A, t2.D, t1.C = t2.A AS Eq FROM t1, t2) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/selexp.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/selexp.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,6 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT 0 AS Zero FROM t1) +val q2 = (SELECT t1.A < t2.D AS Lt FROM t1, t2) +val q3 = (SELECT t1.A < t2.D AS Lt, t1.A, t2.D, t1.C = t2.A AS Eq FROM t1, t2) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sig_impl.lac --- a/tests/sig_impl.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -signature S = sig - type t - val x : t -end - -structure M : S = struct - val x = 0 -end - -signature S = sig - con r :: {Type} - val x : $r -end - -structure M : S = struct - val x = {A = 0, B = "Hi"} -end - -signature S = sig - type t - con r :: {Type} - val x : t -> $r -end - -structure M : S = struct - val x = fn v : int => {A = 0, B = "Hi"} -end - -signature S = sig - con nm :: Name - con t :: Type - con r :: {Type} - val x : $([nm = t] ++ r) -end - -structure M : S = struct - val x = {A = 0, B = "Hi"} -end - -signature S = sig - con nm :: Name - con r :: {Type} - val x : $([nm = int] ++ r) -end - -structure M : S = struct - val x = {A = 0, B = "Hi"} -end - -signature S = sig - con nm :: Name - con r :: {Type} - val x : $([nm = string] ++ r) -end - -structure M : S = struct - val x = {A = 0, B = "Hi"} -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sig_impl.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/sig_impl.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,58 @@ +signature S = sig + type t + val x : t +end + +structure M : S = struct + val x = 0 +end + +signature S = sig + con r :: {Type} + val x : $r +end + +structure M : S = struct + val x = {A = 0, B = "Hi"} +end + +signature S = sig + type t + con r :: {Type} + val x : t -> $r +end + +structure M : S = struct + val x = fn v : int => {A = 0, B = "Hi"} +end + +signature S = sig + con nm :: Name + con t :: Type + con r :: {Type} + val x : $([nm = t] ++ r) +end + +structure M : S = struct + val x = {A = 0, B = "Hi"} +end + +signature S = sig + con nm :: Name + con r :: {Type} + val x : $([nm = int] ++ r) +end + +structure M : S = struct + val x = {A = 0, B = "Hi"} +end + +signature S = sig + con nm :: Name + con r :: {Type} + val x : $([nm = string] ++ r) +end + +structure M : S = struct + val x = {A = 0, B = "Hi"} +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sig_wild.lac --- a/tests/sig_wild.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -signature S = sig - type t - val x : t -end - -structure M : S = struct - type t = _ - val x = 0 -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sig_wild.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/sig_wild.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,9 @@ +signature S = sig + type t + val x : t +end + +structure M : S = struct + type t = _ + val x = 0 +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sigdupe.lac --- a/tests/sigdupe.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -signature S = sig - type t - type t -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/sigdupe.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/sigdupe.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,4 @@ +signature S = sig + type t + type t +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split.lac --- a/tests/split.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -type t = int -val x = 0 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split.lig --- a/tests/split.lig Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -type t -val x : t diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/split.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,2 @@ +type t = int +val x = 0 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/split.urs Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,2 @@ +type t +val x : t diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split2.lac --- a/tests/split2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -val main = Split.x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/split2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/split2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,1 @@ +val main = Split.x diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/strdupe.lac --- a/tests/strdupe.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -val x = 0 -val x = x - -type t = int -type t = { A : t } - -signature S = sig end -signature S = sig type t structure M : S end - -structure S = struct end -structure S : S = struct type t = int structure M = S end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/strdupe.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/strdupe.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,11 @@ +val x = 0 +val x = x + +type t = int +type t = { A : t } + +signature S = sig end +signature S = sig type t structure M : S end + +structure S = struct end +structure S : S = struct type t = int structure M = S end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/stuff.lac --- a/tests/stuff.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -type c1 = t :: Type -> t -con c2 :: Type = t :: Type -> t -con c3 = fn t :: Type => c1 -con c4 = c3 c1 -con c5 = (fn t :: Type => c1) c1 - -con name = #MyName - -con c6 = {A : c1, name : c2} -con c7 = [A = c1, name = c2] - -con c8 = fn t :: Type => t - -con c9 = {} -con c10 = ([]) :: {Type} - -val v1 = fn t :: Type => fn x : t => x -val v2 = v1 [t :: Type -> t -> t] v1 - -val r = {X = v1, Y = v2} -val v1_again = r.X -val v2_again = r.Y - -val r2 = {X = {}, Y = v2, Z = {}} -val r2_X = r2.X -val r2_Y = r2.Y -val r2_Z = r2.Z - -val f = fn fs :: {Type} => fn x : $([X = {}] ++ fs) => x.X -val f2 = fn fs :: {Type} => fn x : $(fs ++ [X = {}]) => x.X -val f3 = fn fs :: {Type} => fn x : $([X = {}, Y = {Z : {}}] ++ fs) => x.X -val f4 = fn fs :: {Type} => fn x : $([X = {}, Y = {Z : {}}] ++ fs) => x.Y -val f5 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2) => x.X -val f6 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2 ++ [Y = {Z : {}}]) => x.X -val f7 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2 ++ [Y = {Z : {}}]) => x.Y - -val test = f [[Y = t :: Type -> t -> t, Z = {}]] r2 -val test = f7 [[Y = t :: Type -> t -> t]] [[Z = {}]] r2 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/stuff.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/stuff.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,38 @@ +type c1 = t :: Type -> t +con c2 :: Type = t :: Type -> t +con c3 = fn t :: Type => c1 +con c4 = c3 c1 +con c5 = (fn t :: Type => c1) c1 + +con name = #MyName + +con c6 = {A : c1, name : c2} +con c7 = [A = c1, name = c2] + +con c8 = fn t :: Type => t + +con c9 = {} +con c10 = ([]) :: {Type} + +val v1 = fn t :: Type => fn x : t => x +val v2 = v1 [t :: Type -> t -> t] v1 + +val r = {X = v1, Y = v2} +val v1_again = r.X +val v2_again = r.Y + +val r2 = {X = {}, Y = v2, Z = {}} +val r2_X = r2.X +val r2_Y = r2.Y +val r2_Z = r2.Z + +val f = fn fs :: {Type} => fn x : $([X = {}] ++ fs) => x.X +val f2 = fn fs :: {Type} => fn x : $(fs ++ [X = {}]) => x.X +val f3 = fn fs :: {Type} => fn x : $([X = {}, Y = {Z : {}}] ++ fs) => x.X +val f4 = fn fs :: {Type} => fn x : $([X = {}, Y = {Z : {}}] ++ fs) => x.Y +val f5 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2) => x.X +val f6 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2 ++ [Y = {Z : {}}]) => x.X +val f7 = fn fs1 :: {Type} => fn fs2 :: {Type} => fn x : $(fs1 ++ [X = {}] ++ fs2 ++ [Y = {Z : {}}]) => x.Y + +val test = f [[Y = t :: Type -> t -> t, Z = {}]] r2 +val test = f7 [[Y = t :: Type -> t -> t]] [[Z = {}]] r2 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_sig.lac --- a/tests/subs_sig.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -signature S = sig - type t -end - -structure S : S = struct - type t = int -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_sig.lig --- a/tests/subs_sig.lig Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -signature S = sig - type t -end - -structure S : S diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_sig.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subs_sig.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,7 @@ +signature S = sig + type t +end + +structure S : S = struct + type t = int +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_sig.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subs_sig.urs Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,5 @@ +signature S = sig + type t +end + +structure S : S diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_str.lac --- a/tests/subs_str.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -structure M = struct - type t = int -end - -val x = 0 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_str.lig --- a/tests/subs_str.lig Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -structure M : sig - type t -end - -val x : M.t diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_str.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subs_str.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,5 @@ +structure M = struct + type t = int +end + +val x = 0 diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subs_str.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subs_str.urs Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,5 @@ +structure M : sig + type t +end + +val x : M.t diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subsig.lac --- a/tests/subsig.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -structure M = struct - signature S = sig - type t - end -end - -structure N : M.S = struct - type t = int -end - -structure M' = struct - type t = int - val y = 42 - - signature S = sig - val x : t - end -end - -structure N' : M'.S = struct - val x = 0 -end - -signature S = sig - type t - val y : t - - signature S = sig - val x : t - end -end - -structure M'S : S = M' - -structure V : M'S.S = struct - val x = M'S.y -end - -structure M'S' = M'S - -structure V : M'S'.S = struct - val x = M'S.y -end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/subsig.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subsig.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,43 @@ +structure M = struct + signature S = sig + type t + end +end + +structure N : M.S = struct + type t = int +end + +structure M' = struct + type t = int + val y = 42 + + signature S = sig + val x : t + end +end + +structure N' : M'.S = struct + val x = 0 +end + +signature S = sig + type t + val y : t + + signature S = sig + val x : t + end +end + +structure M'S : S = M' + +structure V : M'S.S = struct + val x = M'S.y +end + +structure M'S' = M'S + +structure V : M'S'.S = struct + val x = M'S.y +end diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/table.lac --- a/tests/table.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT * FROM t1) - -val q2 = (SELECT * FROM t1, t2) - -(*val q3 = (SELECT * FROM t1, t1)*) -val q3 = (SELECT * FROM t1, t1 AS T2) - -val q4 = (SELECT * FROM {{t1}} AS T, t1 AS T2) - -val q5 = (SELECT t1.A FROM t1) -val q6 = (SELECT t1.B, t1.C, t1.A FROM t1) - -val q7 = (SELECT t1.A, t2.A FROM t1, t2) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/table.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/table.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,16 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT * FROM t1) + +val q2 = (SELECT * FROM t1, t2) + +(*val q3 = (SELECT * FROM t1, t1)*) +val q3 = (SELECT * FROM t1, t1 AS T2) + +val q4 = (SELECT * FROM {{t1}} AS T, t1 AS T2) + +val q5 = (SELECT t1.A FROM t1) +val q6 = (SELECT t1.B, t1.C, t1.A FROM t1) + +val q7 = (SELECT t1.A, t2.A FROM t1, t2) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/textarea.lac --- a/tests/textarea.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -val handler = fn x => - You entered: {cdata x.A} - - -val main = fn () => - - - - - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/textarea.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/textarea.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,10 @@ +val handler = fn x => + You entered: {cdata x.A} + + +val main = fn () => + + + + + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/tuple.lac --- a/tests/tuple.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -val x = (1, 2.0, "Hi") - -val x1 = x.1 -val x2 = x.2 -val x3 = x.3 - -val y : int * float * string = x - -val bizarro_x = case x of (a, b, c) => (c, a, b) - -val main : unit -> page = fn () => - {cdata bizarro_x.1} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/tuple.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/tuple.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,13 @@ +val x = (1, 2.0, "Hi") + +val x1 = x.1 +val x2 = x.2 +val x3 = x.3 + +val y : int * float * string = x + +val bizarro_x = case x of (a, b, c) => (c, a, b) + +val main : unit -> page = fn () => + {cdata bizarro_x.1} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_class.lac --- a/tests/type_class.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -class default t = t - -val string_default : default string = "Hi" -val int_default : default int = 0 - -val default : t :: Type -> default t -> t = - fn t :: Type => fn d : default t => d -val hi = default [string] _ -val zero = default [int] _ - -val frob : t :: Type -> default t -> t = - fn t :: Type => fn _ : default t => default [t] _ -val hi_again = frob [string] _ -val zero_again = frob [int] _ - -val main : unit -> page = fn () => - {cdata hi_again} - diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_class.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/type_class.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,18 @@ +class default t = t + +val string_default : default string = "Hi" +val int_default : default int = 0 + +val default : t :: Type -> default t -> t = + fn t :: Type => fn d : default t => d +val hi = default [string] _ +val zero = default [int] _ + +val frob : t :: Type -> default t -> t = + fn t :: Type => fn _ : default t => default [t] _ +val hi_again = frob [string] _ +val zero_again = frob [int] _ + +val main : unit -> page = fn () => + {cdata hi_again} + diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_classMod.lac --- a/tests/type_classMod.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -structure M = struct - structure N = struct - class c t = t - val string_c : c string = "Hi" - end -end - -val c : t :: Type -> M.N.c t -> t = - fn t :: Type => fn pf : M.N.c t => pf -val hi = c [string] _ - -val bool_c : M.N.c bool = True -val true = c [bool] _ -val hi = c [string] _ - -con c = M.N.c -val int_c : c int = 0 -val zero = c [int] _ diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_classMod.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/type_classMod.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,18 @@ +structure M = struct + structure N = struct + class c t = t + val string_c : c string = "Hi" + end +end + +val c : t :: Type -> M.N.c t -> t = + fn t :: Type => fn pf : M.N.c t => pf +val hi = c [string] _ + +val bool_c : M.N.c bool = True +val true = c [bool] _ +val hi = c [string] _ + +con c = M.N.c +val int_c : c int = 0 +val zero = c [int] _ diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_classMod2.lac --- a/tests/type_classMod2.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -signature S = sig - class c - val default : t :: Type -> c t -> t - - val string_c : c string - val int_c : c int -end - -structure M : S = struct - class c t = t - val default = fn t :: Type => fn v : c t => v - - val int_c : c int = 0 - val string_c : c string = "Hi" -end - -val hi = M.default [string] _ -val zero = M.default [int] _ diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/type_classMod2.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/type_classMod2.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,18 @@ +signature S = sig + class c + val default : t :: Type -> c t -> t + + val string_c : c string + val int_c : c int +end + +structure M : S = struct + class c t = t + val default = fn t :: Type => fn v : c t => v + + val int_c : c int = 0 + val string_c : c string = "Hi" +end + +val hi = M.default [string] _ +val zero = M.default [int] _ diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/where.lac --- a/tests/where.lac Thu Aug 28 14:48:33 2008 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -table t1 : {A : int, B : string, C : float} -table t2 : {A : float, D : int} - -val q1 = (SELECT * FROM t1) -val q2 = (SELECT * FROM t1 WHERE TRUE) -val q3 = (SELECT * FROM t1 WHERE FALSE) -val q4 = (SELECT * FROM t1 WHERE {True}) -val q5 = (SELECT * FROM t1 WHERE {1} = {1}) -val q6 = (SELECT * FROM t1 WHERE {"Hi"} < {"Bye"}) -val q7 = (SELECT * FROM t1 WHERE {1} <> {1} AND NOT ({"Hi"} >= {"Bye"})) -val q8 = (SELECT * FROM t1 WHERE t1.A = 1 OR t1.C < 3.0) diff -r 2b9dfaffb008 -r 71bafe66dbe1 tests/where.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/where.ur Sun Aug 31 08:32:18 2008 -0400 @@ -0,0 +1,11 @@ +table t1 : {A : int, B : string, C : float} +table t2 : {A : float, D : int} + +val q1 = (SELECT * FROM t1) +val q2 = (SELECT * FROM t1 WHERE TRUE) +val q3 = (SELECT * FROM t1 WHERE FALSE) +val q4 = (SELECT * FROM t1 WHERE {True}) +val q5 = (SELECT * FROM t1 WHERE {1} = {1}) +val q6 = (SELECT * FROM t1 WHERE {"Hi"} < {"Bye"}) +val q7 = (SELECT * FROM t1 WHERE {1} <> {1} AND NOT ({"Hi"} >= {"Bye"})) +val q8 = (SELECT * FROM t1 WHERE t1.A = 1 OR t1.C < 3.0)