Mercurial > urweb

annotate src/lacweb.grm @ 224:cb8a68964ebb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
GROUP BY added to query type, with trivial parsing, for now
author Adam Chlipala <adamc@hcoop.net>
date Thu, 21 Aug 2008 12:54:09 -0400
parents bbe5899a9585
children 5ac2cf59b839
rev   line source
adamc@1 1 (* Copyright (c) 2008, Adam Chlipala
adamc@1 2 * All rights reserved.
adamc@1 3 *
adamc@1 4 * Redistribution and use in source and binary forms, with or without
adamc@1 5 * modification, are permitted provided that the following conditions are met:
adamc@1 6 *
adamc@1 7 * - Redistributions of source code must retain the above copyright notice,
adamc@1 8 * this list of conditions and the following disclaimer.
adamc@1 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1 10 * this list of conditions and the following disclaimer in the documentation
adamc@1 11 * and/or other materials provided with the distribution.
adamc@1 12 * - The names of contributors may not be used to endorse or promote products
adamc@1 13 * derived from this software without specific prior written permission.
adamc@1 14 *
adamc@1 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@1 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@1 26 *)
adamc@1 27
adamc@1 28 (* Grammar for Laconic/Web programs *)
adamc@1 29
adamc@4 30 open Source
adamc@1 31
adamc@1 32 val s = ErrorMsg.spanOf
adamc@1 33
adamc@204 34 fun capitalize "" = ""
adamc@204 35 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@104 36
adamc@203 37 fun entable t =
adamc@203 38 case #1 t of
adamc@203 39 TRecord c => c
adamc@203 40 | _ => t
adamc@203 41
adamc@207 42 datatype select_item =
adamc@207 43 Field of con * con
adamc@207 44
adamc@207 45 datatype select =
adamc@207 46 Star
adamc@207 47 | Items of select_item list
adamc@207 48
adamc@207 49 fun eqTnames ((c1, _), (c2, _)) =
adamc@207 50 case (c1, c2) of
adamc@207 51 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
adamc@207 52 | (CName x1, CName x2) => x1 = x2
adamc@207 53 | _ => false
adamc@207 54
adamc@207 55 fun amend_select loc (si, tabs) =
adamc@207 56 let
adamc@207 57 val (tx, c) = case si of
adamc@207 58 Field (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
adamc@207 59
adamc@207 60 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@207 61 if eqTnames (tx, tx') then
adamc@207 62 ((tx', (CConcat (c, c'), loc)), true)
adamc@207 63 else
adamc@207 64 ((tx', c'), found))
adamc@207 65 false tabs
adamc@207 66 in
adamc@207 67 if found then
adamc@207 68 ()
adamc@207 69 else
adamc@207 70 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@207 71
adamc@207 72 tabs
adamc@207 73 end
adamc@207 74
adamc@209 75 fun sql_inject (v, t, loc) =
adamc@209 76 let
adamc@209 77 val e = (EApp ((EVar (["Basis"], "sql_inject"), loc), (v, loc)), loc)
adamc@209 78 in
adamc@209 79 (EApp (e, (t, loc)), loc)
adamc@209 80 end
adamc@209 81
adamc@219 82 fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
adamc@219 83 let
adamc@219 84 val e = (EVar (["Basis"], "sql_comparison"), loc)
adamc@219 85 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@219 86 val e = (EApp (e, sqlexp1), loc)
adamc@219 87 val e = (EApp (e, sqlexp2), loc)
adamc@219 88 in
adamc@220 89 (EApp (e, (EWild, loc)), loc)
adamc@220 90 end
adamc@220 91
adamc@220 92 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
adamc@220 93 let
adamc@220 94 val e = (EVar (["Basis"], "sql_binary"), loc)
adamc@220 95 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@220 96 val e = (EApp (e, sqlexp1), loc)
adamc@220 97 in
adamc@220 98 (EApp (e, sqlexp2), loc)
adamc@220 99 end
adamc@220 100
adamc@220 101 fun sql_unary (oper, sqlexp, loc) =
adamc@220 102 let
adamc@220 103 val e = (EVar (["Basis"], "sql_unary"), loc)
adamc@220 104 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
adamc@220 105 in
adamc@220 106 (EApp (e, sqlexp), loc)
adamc@219 107 end
adamc@219 108
adamc@1 109 %%
adamc@1 110 %header (functor LacwebLrValsFn(structure Token : TOKEN))
adamc@1 111
adamc@1 112 %term
adamc@1 113 EOF
adamc@14 114 | STRING of string | INT of Int64.int | FLOAT of Real64.real
adamc@1 115 | SYMBOL of string | CSYMBOL of string
adamc@1 116 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adamc@156 117 | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@219 118 | DIVIDE | DOTDOTDOT
adamc@211 119 | CON | LTYPE | VAL | REC | AND | FOLD | UNIT | KUNIT | CLASS
adamc@156 120 | DATATYPE | OF
adamc@7 121 | TYPE | NAME
adamc@195 122 | ARROW | LARROW | DARROW | STAR
adamc@149 123 | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
adamc@88 124 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
adamc@203 125 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE
adamc@190 126 | CASE | IF | THEN | ELSE
adamc@1 127
adamc@91 128 | XML_BEGIN of string | XML_END
adamc@91 129 | NOTAGS of string
adamc@91 130 | BEGIN_TAG of string | END_TAG of string
adamc@91 131
adamc@209 132 | SELECT | FROM | AS | CWHERE
adamc@220 133 | TRUE | FALSE | CAND | OR | NOT
adamc@219 134 | NE | LT | LE | GT | GE
adamc@204 135
adamc@30 136 %nonterm
adamc@1 137 file of decl list
adamc@1 138 | decls of decl list
adamc@1 139 | decl of decl
adamc@123 140 | vali of string * con option * exp
adamc@123 141 | valis of (string * con option * exp) list
adamc@1 142
adamc@191 143 | dargs of string list
adamc@156 144 | barOpt of unit
adamc@156 145 | dcons of (string * con option) list
adamc@156 146 | dcon of string * con option
adamc@156 147
adamc@30 148 | sgn of sgn
adamc@42 149 | sgntm of sgn
adamc@30 150 | sgi of sgn_item
adamc@30 151 | sgis of sgn_item list
adamc@30 152
adamc@30 153 | str of str
adamc@30 154
adamc@1 155 | kind of kind
adamc@207 156 | ktuple of kind list
adamc@1 157 | kcolon of explicitness
adamc@1 158
adamc@34 159 | path of string list * string
adamc@156 160 | cpath of string list * string
adamc@34 161 | spath of str
adamc@59 162 | mpath of string list
adamc@34 163
adamc@1 164 | cexp of con
adamc@1 165 | capps of con
adamc@1 166 | cterm of con
adamc@195 167 | ctuple of con list
adamc@207 168 | ctuplev of con list
adamc@1 169 | ident of con
adamc@200 170 | idents of con list
adamc@1 171 | rcon of (con * con) list
adamc@83 172 | rconn of (con * con) list
adamc@1 173 | rcone of (con * con) list
adamc@1 174
adamc@8 175 | eexp of exp
adamc@8 176 | eapps of exp
adamc@8 177 | eterm of exp
adamc@195 178 | etuple of exp list
adamc@12 179 | rexp of (con * exp) list
adamc@91 180 | xml of exp
adamc@91 181 | xmlOne of exp
adamc@141 182 | tag of string * exp
adamc@141 183 | tagHead of string * exp
adamc@8 184
adamc@170 185 | branch of pat * exp
adamc@170 186 | branchs of (pat * exp) list
adamc@170 187 | pat of pat
adamc@170 188 | pterm of pat
adamc@174 189 | rpat of (string * pat) list * bool
adamc@195 190 | ptuple of pat list
adamc@170 191
adamc@104 192 | attrs of (con * exp) list
adamc@104 193 | attr of con * exp
adamc@104 194 | attrv of exp
adamc@104 195
adamc@204 196 | query of exp
adamc@204 197 | tables of (con * exp) list
adamc@204 198 | tname of con
adamc@204 199 | table of con * exp
adamc@207 200 | tident of con
adamc@207 201 | fident of con
adamc@207 202 | seli of select_item
adamc@207 203 | selis of select_item list
adamc@207 204 | select of select
adamc@209 205 | sqlexp of exp
adamc@209 206 | wopt of exp
adamc@207 207
adamc@204 208
adamc@1 209 %verbose (* print summary of errors *)
adamc@1 210 %pos int (* positions *)
adamc@1 211 %start file
adamc@1 212 %pure
adamc@1 213 %eop EOF
adamc@1 214 %noshift EOF
adamc@1 215
adamc@1 216 %name Lacweb
adamc@1 217
adamc@195 218 %nonassoc IF THEN ELSE
adamc@1 219 %nonassoc DARROW
adamc@1 220 %nonassoc COLON
adamc@6 221 %nonassoc DCOLON TCOLON
adamc@1 222 %right COMMA
adamc@220 223 %right OR
adamc@220 224 %right CAND
adamc@219 225 %nonassoc EQ NE LT LE GT GE
adamc@1 226 %right ARROW LARROW
adamc@149 227 %right PLUSPLUS MINUSMINUS
adamc@195 228 %right STAR
adamc@220 229 %left NOT
adamc@84 230 %nonassoc TWIDDLE
adamc@1 231 %nonassoc DOLLAR
adamc@1 232 %left DOT
adamc@221 233 %nonassoc LBRACE RBRACE
adamc@1 234
adamc@1 235 %%
adamc@1 236
adamc@1 237 file : decls (decls)
adamc@54 238 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54 239 s (SIGleft, sgisright))])
adamc@1 240
adamc@1 241 decls : ([])
adamc@1 242 | decl decls (decl :: decls)
adamc@1 243
adamc@1 244 decl : CON SYMBOL EQ cexp (DCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
adamc@1 245 | CON SYMBOL DCOLON kind EQ cexp (DCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
adamc@7 246 | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@7 247 s (LTYPEleft, cexpright))
adamc@191 248 | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
adamc@191 249 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 250 (case dargs of
adamc@191 251 [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 252 | _ => raise Fail "Arguments specified for imported datatype")
adamc@123 253 | VAL vali (DVal vali, s (VALleft, valiright))
adamc@123 254 | VAL REC valis (DValRec valis, s (VALleft, valisright))
adamc@1 255
adamc@30 256 | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@30 257 | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
adamc@30 258 | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
adamc@42 259 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
adamc@42 260 (DStr (CSYMBOL1, NONE,
adamc@42 261 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
adamc@42 262 s (FUNCTORleft, strright))
adamc@42 263 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
adamc@42 264 (DStr (CSYMBOL1, NONE,
adamc@42 265 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
adamc@42 266 s (FUNCTORleft, strright))
adamc@48 267 | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
adamc@61 268 | OPEN mpath (case mpath of
adamc@61 269 [] => raise Fail "Impossible mpath parse [1]"
adamc@61 270 | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
adamc@88 271 | OPEN CONSTRAINTS mpath (case mpath of
adamc@88 272 [] => raise Fail "Impossible mpath parse [3]"
adamc@88 273 | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
adamc@88 274 | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@109 275 | EXPORT spath (DExport spath, s (EXPORTleft, spathright))
adamc@203 276 | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
adamc@211 277 | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright))
adamc@211 278 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 279 val loc = s (CLASSleft, cexpright)
adamc@211 280 val k = (KType, loc)
adamc@211 281 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 282 in
adamc@211 283 (DClass (SYMBOL1, c), s (CLASSleft, cexpright))
adamc@211 284 end)
adamc@30 285
adamc@191 286 dargs : ([])
adamc@191 287 | SYMBOL dargs (SYMBOL :: dargs)
adamc@191 288
adamc@156 289 barOpt : ()
adamc@156 290 | BAR ()
adamc@156 291
adamc@156 292 dcons : dcon ([dcon])
adamc@156 293 | dcon BAR dcons (dcon :: dcons)
adamc@156 294
adamc@156 295 dcon : CSYMBOL (CSYMBOL, NONE)
adamc@156 296 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
adamc@156 297
adamc@123 298 vali : SYMBOL EQ eexp (SYMBOL, NONE, eexp)
adamc@123 299 | SYMBOL COLON cexp EQ eexp (SYMBOL, SOME cexp, eexp)
adamc@123 300
adamc@123 301 valis : vali ([vali])
adamc@123 302 | vali AND valis (vali :: valis)
adamc@123 303
adamc@42 304 sgn : sgntm (sgntm)
adamc@40 305 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@40 306 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
adamc@30 307
adamc@42 308 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
adamc@59 309 | mpath (case mpath of
adamc@61 310 [] => raise Fail "Impossible mpath parse [2]"
adamc@59 311 | [x] => SgnVar x
adamc@59 312 | m :: ms => SgnProj (m,
adamc@59 313 List.take (ms, length ms - 1),
adamc@59 314 List.nth (ms, length ms - 1)),
adamc@59 315 s (mpathleft, mpathright))
adamc@42 316 | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 317 | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42 318 | LPAREN sgn RPAREN (sgn)
adamc@42 319
adamc@30 320 sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
adamc@30 321 | LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
adamc@30 322 s (LTYPEleft, SYMBOLright))
adamc@30 323 | CON SYMBOL EQ cexp (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
adamc@30 324 | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
adamc@30 325 | LTYPE SYMBOL EQ cexp (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@30 326 s (LTYPEleft, cexpright))
adamc@191 327 | DATATYPE SYMBOL dargs EQ barOpt dcons(SgiDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))
adamc@191 328 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 329 (case dargs of
adamc@191 330 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 331 | _ => raise Fail "Arguments specified for imported datatype")
adamc@30 332 | VAL SYMBOL COLON cexp (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
adamc@30 333
adamc@30 334 | STRUCTURE CSYMBOL COLON sgn (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
adamc@59 335 | SIGNATURE CSYMBOL EQ sgn (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@42 336 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@42 337 (SgiStr (CSYMBOL1,
adamc@42 338 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
adamc@42 339 s (FUNCTORleft, sgn2right))
adamc@58 340 | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright))
adamc@88 341 | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@203 342 | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))
adamc@211 343 | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright))
adamc@211 344 | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright))
adamc@211 345 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 346 val loc = s (CLASSleft, cexpright)
adamc@211 347 val k = (KType, loc)
adamc@211 348 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 349 in
adamc@211 350 (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright))
adamc@211 351 end)
adamc@30 352
adamc@30 353 sgis : ([])
adamc@30 354 | sgi sgis (sgi :: sgis)
adamc@30 355
adamc@30 356 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
adamc@34 357 | spath (spath)
adamc@40 358 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
adamc@40 359 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
adamc@40 360 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
adamc@40 361 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
adamc@44 362 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
adamc@34 363
adamc@34 364 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@34 365 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
adamc@30 366
adamc@1 367 kind : TYPE (KType, s (TYPEleft, TYPEright))
adamc@1 368 | NAME (KName, s (NAMEleft, NAMEright))
adamc@1 369 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
adamc@1 370 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
adamc@1 371 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
adamc@82 372 | KUNIT (KUnit, s (KUNITleft, KUNITright))
adamc@18 373 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
adamc@207 374 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
adamc@207 375
adamc@207 376 ktuple : kind STAR kind ([kind1, kind2])
adamc@207 377 | kind STAR ktuple (kind :: ktuple)
adamc@1 378
adamc@1 379 capps : cterm (cterm)
adamc@1 380 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
adamc@1 381
adamc@1 382 cexp : capps (capps)
adamc@1 383 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
adamc@15 384 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
adamc@1 385
adamc@1 386 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
adamc@1 387
adamc@67 388 | FN SYMBOL DARROW cexp (CAbs (SYMBOL, NONE, cexp), s (FNleft, cexpright))
adamc@67 389 | FN SYMBOL DCOLON kind DARROW cexp (CAbs (SYMBOL, SOME kind, cexp), s (FNleft, cexpright))
adamc@84 390 | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@85 391 | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@1 392
adamc@8 393 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
adamc@6 394
adamc@18 395 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
adamc@195 396 | ctuple (let
adamc@195 397 val loc = s (ctupleleft, ctupleright)
adamc@195 398 in
adamc@195 399 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
adamc@195 400 ((CName (Int.toString (i + 1)), loc),
adamc@195 401 c)) ctuple),
adamc@195 402 loc), loc)
adamc@195 403 end)
adamc@18 404
adamc@1 405 kcolon : DCOLON (Explicit)
adamc@1 406 | TCOLON (Implicit)
adamc@1 407
adamc@34 408 path : SYMBOL ([], SYMBOL)
adamc@34 409 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
adamc@34 410
adamc@156 411 cpath : CSYMBOL ([], CSYMBOL)
adamc@156 412 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
adamc@156 413
adamc@59 414 mpath : CSYMBOL ([CSYMBOL])
adamc@59 415 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
adamc@59 416
adamc@1 417 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
adamc@1 418 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
adamc@83 419 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
adamc@1 420 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
adamc@1 421 s (LBRACEleft, RBRACEright))
adamc@1 422 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
adamc@1 423 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
adamc@195 424 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
adamc@1 425
adamc@34 426 | path (CVar path, s (pathleft, pathright))
adamc@207 427 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
adamc@207 428 s (pathleft, INTright))
adamc@18 429 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
adamc@67 430 | FOLD (CFold, s (FOLDleft, FOLDright))
adamc@82 431 | UNIT (CUnit, s (UNITleft, UNITright))
adamc@207 432 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
adamc@207 433
adamc@207 434 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
adamc@207 435 | cexp COMMA ctuplev (cexp :: ctuplev)
adamc@1 436
adamc@196 437 ctuple : capps STAR capps ([capps1, capps2])
adamc@196 438 | capps STAR ctuple (capps :: ctuple)
adamc@195 439
adamc@1 440 rcon : ([])
adamc@1 441 | ident EQ cexp ([(ident, cexp)])
adamc@1 442 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
adamc@1 443
adamc@83 444 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
adamc@83 445 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
adamc@83 446
adamc@1 447 rcone : ([])
adamc@1 448 | ident COLON cexp ([(ident, cexp)])
adamc@1 449 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
adamc@1 450
adamc@1 451 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@195 452 | INT (CName (Int64.toString INT), s (INTleft, INTright))
adamc@200 453 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@8 454
adamc@8 455 eapps : eterm (eterm)
adamc@8 456 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
adamc@8 457 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
adamc@8 458
adamc@8 459 eexp : eapps (eapps)
adamc@8 460 | FN SYMBOL kcolon kind DARROW eexp (ECAbs (kcolon, SYMBOL, kind, eexp), s (FNleft, eexpright))
adamc@8 461 | FN SYMBOL COLON cexp DARROW eexp (EAbs (SYMBOL, SOME cexp, eexp), s (FNleft, eexpright))
adamc@8 462 | FN SYMBOL DARROW eexp (EAbs (SYMBOL, NONE, eexp), s (FNleft, eexpright))
adamc@212 463 | FN UNDER COLON cexp DARROW eexp (EAbs ("_", SOME cexp, eexp), s (FNleft, eexpright))
adamc@93 464 | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright))
adamc@93 465 | FN UNIT DARROW eexp (let
adamc@93 466 val loc = s (FNleft, eexpright)
adamc@93 467 in
adamc@93 468 (EAbs ("_", SOME (TRecord (CRecord [], loc), loc), eexp), loc)
adamc@93 469 end)
adamc@8 470
adamc@196 471 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
adamc@149 472 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
adamc@170 473 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
adamc@190 474 | IF eexp THEN eexp ELSE eexp (let
adamc@190 475 val loc = s (IFleft, eexp3right)
adamc@190 476 in
adamc@190 477 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
adamc@190 478 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
adamc@190 479 end)
adamc@8 480
adamc@8 481 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
adamc@195 482 | LPAREN etuple RPAREN (let
adamc@195 483 val loc = s (LPARENleft, RPARENright)
adamc@195 484 in
adamc@195 485 (ERecord (ListUtil.mapi (fn (i, e) =>
adamc@195 486 ((CName (Int.toString (i + 1)), loc),
adamc@195 487 e)) etuple), loc)
adamc@195 488 end)
adamc@8 489
adamc@34 490 | path (EVar path, s (pathleft, pathright))
adamc@156 491 | cpath (EVar cpath, s (cpathleft, cpathright))
adamc@12 492 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
adamc@110 493 | UNIT (ERecord [], s (UNITleft, UNITright))
adamc@12 494
adamc@14 495 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@14 496 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@14 497 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@14 498
adamc@200 499 | path DOT idents (let
adamc@200 500 val loc = s (pathleft, identsright)
adamc@200 501 in
adamc@200 502 foldl (fn (ident, e) =>
adamc@200 503 (EField (e, ident), loc))
adamc@200 504 (EVar path, s (pathleft, pathright)) idents
adamc@200 505 end)
adamc@71 506 | FOLD (EFold, s (FOLDleft, FOLDright))
adamc@71 507
adamc@91 508 | XML_BEGIN xml XML_END (xml)
adamc@91 509 | XML_BEGIN XML_END (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)),
adamc@91 510 (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
adamc@91 511 s (XML_BEGINleft, XML_ENDright))
adamc@204 512 | LPAREN query RPAREN (query)
adamc@211 513 | UNDER (EWild, s (UNDERleft, UNDERright))
adamc@91 514
adamc@200 515 idents : ident ([ident])
adamc@200 516 | ident DOT idents (ident :: idents)
adamc@200 517
adamc@195 518 etuple : eexp COMMA eexp ([eexp1, eexp2])
adamc@195 519 | eexp COMMA etuple (eexp :: etuple)
adamc@195 520
adamc@170 521 branch : pat DARROW eexp (pat, eexp)
adamc@170 522
adamc@170 523 branchs: ([])
adamc@170 524 | BAR branch branchs (branch :: branchs)
adamc@170 525
adamc@170 526 pat : pterm (pterm)
adamc@170 527 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
adamc@170 528
adamc@170 529 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@170 530 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
adamc@170 531 | UNDER (PWild, s (UNDERleft, UNDERright))
adamc@173 532 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
adamc@173 533 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@170 534 | LPAREN pat RPAREN (pat)
adamc@174 535 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
adamc@174 536 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
adamc@174 537 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
adamc@195 538 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
adamc@195 539 false),
adamc@195 540 s (LPARENleft, RPARENright))
adamc@174 541
adamc@175 542 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
adamc@174 543 | DOTDOTDOT ([], true)
adamc@175 544 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
adamc@170 545
adamc@195 546 ptuple : pat COMMA pat ([pat1, pat2])
adamc@195 547 | pat COMMA ptuple (pat :: ptuple)
adamc@195 548
adamc@12 549 rexp : ([])
adamc@12 550 | ident EQ eexp ([(ident, eexp)])
adamc@12 551 | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
adamc@91 552
adamc@141 553 xml : xmlOne xml (let
adamc@141 554 val pos = s (xmlOneleft, xmlright)
adamc@141 555 in
adamc@141 556 (EApp ((EApp (
adamc@141 557 (EVar (["Basis"], "join"), pos),
adamc@91 558 xmlOne), pos),
adamc@141 559 xml), pos)
adamc@141 560 end)
adamc@141 561 | xmlOne (xmlOne)
adamc@91 562
adamc@141 563 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
adamc@141 564 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
adamc@141 565 s (NOTAGSleft, NOTAGSright))
adamc@141 566 | tag DIVIDE GT (let
adamc@141 567 val pos = s (tagleft, GTright)
adamc@141 568 in
adamc@141 569 (EApp (#2 tag,
adamc@141 570 (EApp ((EVar (["Basis"], "cdata"), pos),
adamc@141 571 (EPrim (Prim.String ""), pos)),
adamc@141 572 pos)), pos)
adamc@141 573 end)
adamc@141 574
adamc@141 575 | tag GT xml END_TAG (let
adamc@141 576 val pos = s (tagleft, GTright)
adamc@141 577 in
adamc@141 578 if #1 tag = END_TAG then
adamc@141 579 if END_TAG = "lform" then
adamc@141 580 (EApp ((EVar (["Basis"], "lform"), pos),
adamc@141 581 xml), pos)
adamc@141 582 else
adamc@141 583 (EApp (#2 tag, xml), pos)
adamc@141 584 else
adamc@141 585 (ErrorMsg.errorAt pos "Begin and end tags don't match.";
adamc@141 586 (EFold, pos))
adamc@141 587 end)
adamc@141 588 | LBRACE eexp RBRACE (eexp)
adamc@92 589
adamc@141 590 tag : tagHead attrs (let
adamc@141 591 val pos = s (tagHeadleft, attrsright)
adamc@141 592 in
adamc@141 593 (#1 tagHead,
adamc@141 594 (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
adamc@141 595 (ERecord attrs, pos)), pos),
adamc@141 596 (EApp (#2 tagHead,
adamc@141 597 (ERecord [], pos)), pos)),
adamc@141 598 pos))
adamc@141 599 end)
adamc@141 600
adamc@141 601 tagHead: BEGIN_TAG (let
adamc@141 602 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141 603 in
adamc@141 604 (BEGIN_TAG,
adamc@141 605 (EVar ([], BEGIN_TAG), pos))
adamc@141 606 end)
adamc@141 607 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92 608
adamc@104 609 attrs : ([])
adamc@104 610 | attr attrs (attr :: attrs)
adamc@104 611
adamc@204 612 attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
adamc@204 613
adamc@104 614 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104 615 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@104 616 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@110 617 | LBRACE eexp RBRACE (eexp)
adamc@204 618
adamc@209 619 query : SELECT select FROM tables wopt
adamc@209 620 (let
adamc@204 621 val loc = s (SELECTleft, tablesright)
adamc@207 622
adamc@207 623 val sel =
adamc@207 624 case select of
adamc@207 625 Star => map (fn (nm, _) =>
adamc@207 626 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
adamc@207 627 loc),
adamc@207 628 (CRecord [], loc)],
adamc@207 629 loc))) tables
adamc@207 630 | Items sis =>
adamc@207 631 let
adamc@207 632 val tabs = map (fn (nm, _) => (nm, (CRecord [], loc))) tables
adamc@207 633 val tabs = foldl (amend_select loc) tabs sis
adamc@207 634 in
adamc@207 635 map (fn (nm, c) => (nm,
adamc@207 636 (CTuple [c,
adamc@207 637 (CWild (KRecord (KType, loc), loc),
adamc@207 638 loc)], loc))) tabs
adamc@207 639 end
adamc@207 640
adamc@207 641 val sel = (CRecord sel, loc)
adamc@207 642
adamc@223 643 val hopt = (sql_inject (EVar (["Basis"], "True"),
adamc@223 644 EVar (["Basis"], "sql_bool"),
adamc@223 645 loc))
adamc@223 646
adamc@207 647 val e = (EVar (["Basis"], "sql_query"), loc)
adamc@223 648 val _ = [((CName "GroupBy", loc),
adamc@223 649 (ECApp ((EVar (["Basis"], "sql_subset_all"), loc),
adamc@223 650 (CWild (KRecord (KType, loc), loc), loc)), loc)),
adamc@223 651 ((CName "Having", loc),
adamc@223 652 hopt)]
adamc@209 653 val re = (ERecord [((CName "From", loc),
adamc@209 654 (ERecord tables, loc)),
adamc@209 655 ((CName "Where", loc),
adamc@223 656 wopt),
adamc@224 657 ((CName "GroupBy", loc),
adamc@224 658 (ECApp ((EVar (["Basis"], "sql_subset_all"), loc),
adamc@224 659 (CWild (KRecord (KRecord (KType, loc), loc),
adamc@224 660 loc), loc)), loc)),
adamc@224 661 ((CName "Having", loc),
adamc@224 662 hopt),
adamc@223 663 ((CName "SelectFields", loc),
adamc@223 664 (ECApp ((EVar (["Basis"], "sql_subset"), loc),
adamc@223 665 sel), loc))], loc)
adamc@223 666
adamc@209 667 val e = (EApp (e, re), loc)
adamc@204 668 in
adamc@207 669 e
adamc@204 670 end)
adamc@204 671
adamc@204 672 tables : table ([table])
adamc@204 673 | table COMMA tables (table :: tables)
adamc@204 674
adamc@204 675 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@204 676 | LBRACE cexp RBRACE (cexp)
adamc@204 677
adamc@207 678 table : SYMBOL ((CName SYMBOL, s (SYMBOLleft, SYMBOLright)),
adamc@204 679 (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
adamc@204 680 | SYMBOL AS tname (tname, (EVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)))
adamc@221 681 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
adamc@207 682
adamc@207 683 tident : SYMBOL (CName SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@207 684 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@221 685 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
adamc@207 686
adamc@207 687 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@207 688 | LBRACE cexp RBRACE (cexp)
adamc@207 689
adamc@207 690 seli : tident DOT fident (Field (tident, fident))
adamc@207 691
adamc@207 692 selis : seli ([seli])
adamc@207 693 | seli COMMA selis (seli :: selis)
adamc@207 694
adamc@207 695 select : STAR (Star)
adamc@207 696 | selis (Items selis)
adamc@209 697
adamc@209 698 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"),
adamc@209 699 EVar (["Basis"], "sql_bool"),
adamc@209 700 s (TRUEleft, TRUEright)))
adamc@209 701 | FALSE (sql_inject (EVar (["Basis"], "False"),
adamc@209 702 EVar (["Basis"], "sql_bool"),
adamc@209 703 s (FALSEleft, FALSEright)))
adamc@209 704
adamc@222 705 | INT (sql_inject (EPrim (Prim.Int INT),
adamc@222 706 EVar (["Basis"], "sql_int"),
adamc@222 707 s (INTleft, INTright)))
adamc@222 708 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
adamc@222 709 EVar (["Basis"], "sql_float"),
adamc@222 710 s (FLOATleft, FLOATright)))
adamc@222 711
adamc@221 712 | tident DOT fident (let
adamc@221 713 val loc = s (tidentleft, fidentright)
adamc@221 714 val e = (EVar (["Basis"], "sql_field"), loc)
adamc@221 715 val e = (ECApp (e, tident), loc)
adamc@221 716 in
adamc@221 717 (ECApp (e, fident), loc)
adamc@221 718 end)
adamc@221 719
adamc@219 720 | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 721 | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 722 | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 723 | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 724 | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 725 | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 726
adamc@220 727 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 728 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 729 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
adamc@220 730
adamc@210 731 | LBRACE eexp RBRACE (sql_inject (#1 eexp,
adamc@211 732 EWild,
adamc@210 733 s (LBRACEleft, RBRACEright)))
adamc@220 734 | LPAREN sqlexp RPAREN (sqlexp)
adamc@210 735
adamc@209 736 wopt : (sql_inject (EVar (["Basis"], "True"),
adamc@209 737 EVar (["Basis"], "sql_bool"),
adamc@209 738 ErrorMsg.dummySpan))
adamc@209 739 | CWHERE sqlexp (sqlexp)