Ur/Web: src/urweb.grm comparison

comparison src/urweb.grm @ 2206:c1a62ce47083

Merge.

author	Ziv Scully <ziv@mit.edu>
date	Tue, 27 May 2014 21:38:01 -0400
parents	403f0cc65b9c
children	afeeabdcce77

comparison

equal deleted inserted replaced

-:cdea39473c78
+:c1a62ce47083
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2014, 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:
 *
 "table" => "tabl"
 | _ => bt
 datatype prop_kind = Delete | Update
-datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp
 fun patType loc (p : pat) =
 case #1 p of
 PAnnot (_, t) => t
 | _ => (CWild (KType, loc), loc)
 val e' = (EApp (e', pb), loc)
 in
 (EApp (e', ob), loc)
 end
+fun patternOut (e : exp) =
+case #1 e of
+EWild => (PWild, #2 e)
+| EVar ([], x, Infer) =>
+if Char.isUpper (String.sub (x, 0)) then
+(PCon ([], x, NONE), #2 e)
+else
+(PVar x, #2 e)
+| EVar (xs, x, Infer) =>
+if Char.isUpper (String.sub (x, 0)) then
+(PCon (xs, x, NONE), #2 e)
+else
+(ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern";
+(PWild, #2 e))
+| EPrim p => (PPrim p, #2 e)
+| EApp ((EVar (xs, x, Infer), _), e') =>
+(PCon (xs, x, SOME (patternOut e')), #2 e)
+| ERecord (xes, flex) =>
+(PRecord (map (fn (x, e') =>
+let
+val x =
+case #1 x of
+CName x => x
+| _ => (ErrorMsg.errorAt (#2 e) "Field name not constant in pattern";
+"")
+in
+(x, patternOut e')
+end) xes, flex), #2 e)
+| EAnnot (e', t) =>
+(PAnnot (patternOut e', t), #2 e)
+| _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern.";
+(PWild, #2 e))
 %%
 %header (functor UrwebLrValsFn(structure Token : TOKEN))
 %term
 EOF
 | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
 | SYMBOL of string | CSYMBOL of string
 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
 | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
 | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
-| CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
+| CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI
 | DATATYPE | OF
 | TYPE | NAME
 | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
 | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
 | LET | IN
 | eexp of exp
 | eapps of exp
 | eterm of exp
 | etuple of exp list
-| rexp of (con * exp) list
+| rexp of (con * exp) list * bool
 | xml of exp
 | xmlOne of exp
 | xmlOpt of exp
 | tag of (string * exp) * exp option * exp option * exp
 | tagHead of string * exp
-| bind of string * con option * exp
+| bind of pat * con option * exp
 | edecl of edecl
 | edecls of edecl list
 | earg of exp * con -> exp * con
 | eargp of exp * con -> exp * con
 | patS of pat
 | pterm of pat
 | rpat of (string * pat) list * bool
 | ptuple of pat list
-| attrs of exp option * exp option * exp option * exp option * (con * exp) list
+| attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
 | attr of attr
 | attrv of exp
 | query of exp
 | query1 of exp
 | sqlexps of exp list
 | fsets of (con * exp) list
 | enterDml of unit
 | leaveDml of unit
+| ffi_mode of ffi_mode
+| ffi_modes of ffi_mode list
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)
 %start file
 %pure
 s (VIEWleft, RBRACEright))])
 | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
 | STYLE SYMBOL                   ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
 | TASK eapps EQ eexp             ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
 | POLICY eexp                    ([(DPolicy eexp, s (POLICYleft, eexpright))])
+| FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))])
 dtype  : SYMBOL dargs EQ barOpt dcons   (SYMBOL, dargs, dcons)
 dtypes : dtype                          ([dtype])
 | dtype AND dtypes               (dtype :: dtypes)
 val e = (EVar (["Basis"], "foreign_key", Infer), loc)
 val e = (EApp (e, mat), loc)
 val e = (EApp (e, texp), loc)
 in
-(EApp (e, (ERecord [((CName "OnDelete", loc),
+(EApp (e, (ERecord ([((CName "OnDelete", loc),
 findMode Delete),
 ((CName "OnUpdate", loc),
-findMode Update)], loc)), loc)
+findMode Update)], false), loc)), loc)
 end)
 | LBRACE eexp RBRACE             (eexp)
 tnameW : tname                          (let
 val e = (EDisjointApp e, loc)
 val witness = map (fn (c, _) =>
 (c, (EWild, loc)))
 (#1 tnames :: #2 tnames)
-val witness = (ERecord witness, loc)
+val witness = (ERecord (witness, false), loc)
 in
 (EApp (e, witness), loc)
 end)
 pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), dummy)
 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
 end)
 | bind SEMI eexp                 (let
 val loc = s (bindleft, eexpright)
-val (v, to, e1) = bind
+val (p, to, e1) = bind
 val e = (EVar (["Basis"], "bind", Infer), loc)
 val e = (EApp (e, e1), loc)
-in
-(EApp (e, (EAbs (v, to, eexp), loc)), loc)
+val f = case #1 p of
+PVar v => (EAbs (v, to, eexp), loc)
+| _ => (EAbs ("$x", to,
+(ECase ((EVar ([], "$x", Infer), loc),
+[(p, eexp)]), loc)), loc)
+in
+(EApp (e, f), loc)
 end)
 | eexp EQ eexp                   (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
 | eexp NE eexp                   (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
 | MINUS eterm                    (native_unop ("neg", eterm, s (MINUSleft, etermright)))
 | eexp PLUS eexp                 (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right)))
 | eapps DCOLON eexp              (let
 val loc = s (eappsleft, eexpright)
 in
 (EApp ((EVar (["Basis"], "Cons", Infer), loc),
-(ERecord [((CName "1", loc),
+(ERecord ([((CName "1", loc),
 eapps),
 ((CName "2", loc),
-eexp)], loc)), loc)
+eexp)], false), loc)), loc)
 end)
-bind   : SYMBOL LARROW eapps            (SYMBOL, NONE, eapps)
+bind   : eapps LARROW eapps             (patternOut eapps1, NONE, eapps2)
 | eapps                          (let
 val loc = s (eappsleft, eappsright)
 in
-("_", SOME (TRecord (CRecord [], loc), loc), eapps)
+((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps)
 end)
 eargs  : earg                           (earg)
 | eargl                          (eargl)
 | 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)
+e)) etuple, false), loc)
 end)
 | path                           (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
 | cpath                          (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright))
 | AT path                        (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright))
 | AT AT path                     (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright))
 | AT cpath                       (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
 | AT AT cpath                    (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
 | LBRACE rexp RBRACE             (ERecord rexp, s (LBRACEleft, RBRACEright))
-| UNIT                           (ERecord [], s (UNITleft, UNITright))
+| LBRACE RBRACE                  (ERecord ([], false), s (LBRACEleft, RBRACEright))
+| UNIT                           (ERecord ([], false), 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))
 | CHAR                           (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
 ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification ("
 ^ Int.toString (length fields)
 ^ " vs. " ^ Int.toString (length sqlexps) ^ ")")
 else
 ();
-(EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
+(EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc)
 end)
 | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
 (let
 val loc = s (LPARENleft, RPARENright)
 val e = (EVar (["Basis"], "update", Infer), loc)
 val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
-val e = (EApp (e, (ERecord fsets, loc)), loc)
+val e = (EApp (e, (ERecord (fsets, false), loc)), loc)
 val e = (EApp (e, texp), loc)
 in
 (EApp (e, sqlexp), loc)
 end)
 | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN
 | 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   :                                ([])
+rexp   : DOTDOTDOT                      ([], true)
-| ident EQ eexp                  ([(ident, eexp)])
+| ident EQ eexp                  ([(ident, eexp)], false)
-| ident EQ eexp COMMA rexp       ((ident, eexp) :: rexp)
+| ident EQ eexp COMMA rexp       ((ident, eexp) :: #1 rexp, #2 rexp)
 xml    : xmlOne xml                     (let
 val pos = s (xmlOneleft, xmlright)
 in
 (EApp ((EApp (
 val eo = case #4 attrs of
 NONE => (EVar (["Basis"], "None", Infer), pos)
 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
 e), pos)
 val e = (EApp (e, eo), pos)
-val e = (EApp (e, (ERecord (#5 attrs), pos)), pos)
+val atts = case #5 attrs of
+[] => #6 attrs
+| data :: datas =>
+let
+fun doOne (name, value) =
+let
+val e = (EVar (["Basis"], "data_attr", Infer), pos)
+val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
+in
+(EApp (e, value), pos)
+end
+val datas' = foldl (fn (nv, acc) =>
+let
+val e = (EVar (["Basis"], "data_attrs", Infer), pos)
+val e = (EApp (e, acc), pos)
+in
+(EApp (e, doOne nv), pos)
+end) (doOne data) datas
+in
+((CName "Data", pos), datas') :: #6 attrs
+end
+val e = (EApp (e, (ERecord (atts, false), pos)), pos)
 val e = (EApp (e, (EApp (#2 tagHead,
-(ERecord [], pos)), pos)), pos)
+(ERecord ([], false), pos)), pos)), pos)
 in
 (tagHead, #1 attrs, #2 attrs, e)
 end)
 tagHead: BEGIN_TAG                      (let
 (bt,
 (EVar ([], bt, Infer), pos))
 end)
 | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs  :                                (NONE, NONE, NONE, NONE, [])
+attrs  :                                (NONE, NONE, NONE, NONE, [], [])
 | attr attrs                     (let
 val loc = s (attrleft, attrsright)
 in
 case attr of
 Class e =>
 (case #1 attrs of
 NONE => ()
 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-(SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
+(SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
 | DynClass e =>
 (case #2 attrs of
 NONE => ()
 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-(#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs))
+(#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
 | Style e =>
 (case #3 attrs of
 NONE => ()
 | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
-(#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs))
+(#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
 | DynStyle e =>
 (case #4 attrs of
 NONE => ()
 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-(#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs))
+(#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+| Data xe =>
+(#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
 | Normal xe =>
-(#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
+(#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
 end)
 attr   : SYMBOL EQ attrv                (case SYMBOL of
 					     "class" => Class attrv
 					   | "dynClass" => DynClass attrv
 | "style" => Style attrv
 					   | "dynStyle" => DynStyle attrv
 					   | _ =>
-let
+if String.isPrefix "data-" SYMBOL then
-val sym = makeAttr SYMBOL
+Data (String.extract (SYMBOL, 5, NONE), attrv)
-in
+else
-Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
+let
-if (sym = "Href" orelse sym = "Src")
+val sym = makeAttr SYMBOL
-andalso (case #1 attrv of
+in
-EPrim _ => true
+Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
-| _ => false) then
+if (sym = "Href" orelse sym = "Src")
-let
+andalso (case #1 attrv of
-val loc = s (attrvleft, attrvright)
+EPrim _ => true
-in
+| _ => false) then
-(EApp ((EVar (["Basis"], "bless", Infer), loc),
+let
-attrv), loc)
+val loc = s (attrvleft, attrvright)
-end
+in
-else
+(EApp ((EVar (["Basis"], "bless", Infer), loc),
-attrv)
+attrv), loc)
-end)
+end
+else
+attrv)
+end)
 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),
+val re = (ERecord ([((CName "Rows", loc),
 query1),
 ((CName "OrderBy", loc),
 obopt),
 ((CName "Limit", loc),
 lopt),
 ((CName "Offset", loc),
-ofopt)], loc)
+ofopt)], false), loc)
 in
 (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
 end)
 dopt   :                                (EVar (["Basis"], "False", Infer), dummy)
 end
 val e = (EVar (["Basis"], "sql_query1", Infer), loc)
 val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
 loc)), loc)
-val re = (ERecord [((CName "Distinct", loc),
+val re = (ERecord ([((CName "Distinct", loc),
 dopt),
 ((CName "From", loc),
 #2 tables),
 ((CName "Where", loc),
 wopt),
 ((CName "GroupBy", loc),
 grp),
 ((CName "Having", loc),
 hopt),
 ((CName "SelectFields", loc),
 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
 sel), loc)),
 ((CName "SelectExps", loc),
-(ERecord exps, loc))], loc)
+(ERecord (exps, false), loc))], false), loc)
 val e = (EApp (e, re), loc)
 in
 e
 end)
 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
 val e = (ECApp (e, tname), loc)
 in
 ([tname], (EApp (e, query), loc))
 end)
+| LPAREN fitem RPAREN            (fitem)
 tname  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
 | LBRACE cexp RBRACE             (cexp)
 table  : SYMBOL                         ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
 sqlagg : AVG                             ("avg")
 | SUM                             ("sum")
 | MIN                             ("min")
 | MAX                             ("max")
+ffi_mode : SYMBOL                        (case SYMBOL of
+"effectful" => Effectful
+| "benignEffectful" => BenignEffectful
+| "clientOnly" => ClientOnly
+| "serverOnly" => ServerOnly
+| _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+| SYMBOL STRING                 (case SYMBOL of
+"jsFunc" => JsFunc STRING
+| _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+ffi_modes :                              ([])
+| ffi_mode ffi_modes           (ffi_mode :: ffi_modes)

Mercurial > urweb

comparison src/urweb.grm @ 2206:c1a62ce47083