Ur/Web: src/lacweb.grm comparison

comparison src/lacweb.grm @ 207:cc68da3801bc

Non-star SELECT

author	Adam Chlipala <adamc@hcoop.net>
date	Thu, 14 Aug 2008 18:35:08 -0400
parents	241c9a0e3397
children	1487c712eb12

comparison

equal deleted inserted replaced

-:cb8493759a7b
+:cc68da3801bc
 fun entable t =
 case #1 t of
 TRecord c => c
 | _ => t
+datatype select_item =
+Field of con * con
+datatype select =
+Star
+| Items of select_item list
+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) =
+let
+val (tx, c) = case si of
+Field (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
 %%
 %header (functor LacwebLrValsFn(structure Token : TOKEN))
 %term
 EOF
 | sgis of sgn_item list
 | str of str
 | kind of kind
+| ktuple of kind list
 | kcolon of explicitness
 | path of string list * string
 | cpath of string list * string
 | spath of str
 | 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
 | query 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
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)
 %start file
 %pure
 | 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)
 | 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   :                                ([])
 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  : SELECT STAR FROM tables        (let
+query  : SELECT select FROM tables      (let
 val loc = s (SELECTleft, tablesright)
-in
-(EApp ((EVar (["Basis"], "sql_query"), loc),
+val sel =
-(ERecord tables, loc)), loc)
+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 = foldl (amend_select loc) tabs sis
+in
+map (fn (nm, c) => (nm,
+(CTuple [c,
+(CWild (KRecord (KType, loc), loc),
+loc)], loc))) tabs
+end
+val sel = (CRecord sel, loc)
+val e = (EVar (["Basis"], "sql_query"), loc)
+val e = (ECApp (e, sel), loc)
+val e = (EApp (e, (ERecord tables, loc)), loc)
+in
+e
 end)
 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)),
+table  : SYMBOL                         ((CName SYMBOL, s (SYMBOLleft, SYMBOLright)),
 (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
 | SYMBOL AS tname                (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
 | LBRACE eexp RBRACE AS tname    (tname, eexp)
+tident : SYMBOL                         (CName SYMBOL, s (SYMBOLleft, SYMBOLright))
+| CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+| LBRACE cexp RBRACE             (cexp)
+fident : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+| LBRACE cexp RBRACE             (cexp)
+seli   : tident DOT fident              (Field (tident, fident))
+selis  : seli                           ([seli])
+| seli COMMA selis               (seli :: selis)
+select : STAR                           (Star)
+| selis                          (Items selis)

Mercurial > urweb

comparison src/lacweb.grm @ 207:cc68da3801bc