Ur/Web: src/urweb.grm comparison

comparison src/urweb.grm @ 2009:799be3911ce3

Monadic bind supports patterns

author	Adam Chlipala <adam@chlipala.net>
date	Fri, 02 May 2014 17:16:02 -0400
parents	93ff76058825
children	403f0cc65b9c

comparison

equal deleted inserted replaced

-:93ff76058825
+:799be3911ce3
 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
 | 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
 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 (
 end) (doOne data) datas
 in
 ((CName "Data", pos), datas') :: #6 attrs
 end
-val e = (EApp (e, (ERecord atts, pos)), pos)
+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
 | 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)

Mercurial > urweb

comparison src/urweb.grm @ 2009:799be3911ce3