Mercurial > urweb

annotate src/urweb.grm @ 2067:88841212f0ba

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
In computing command lines, put filenames inside of quotes, to support spaces and other funky characters nicely
author Adam Chlipala <adam@chlipala.net>
date Thu, 04 Sep 2014 08:40:14 -0400
parents 4d64af730e35
children fde864eacd47
rev   line source
adam@2010 1 (* Copyright (c) 2008-2014, 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@339 15 * THIS SOFTARE 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@244 28 (* Grammar for Ur/Web programs *)
adamc@1 29
adamc@4 30 open Source
adamc@1 31
adamc@1 32 val s = ErrorMsg.spanOf
adamc@230 33 val dummy = ErrorMsg.dummySpan
adamc@1 34
adamc@204 35 fun capitalize "" = ""
adamc@204 36 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@104 37
adam@1840 38 fun makeAttr s =
adam@1840 39 case s of
adam@1840 40 "type" => "Typ"
adam@1840 41 | "name" => "Nam"
adam@1840 42 | _ => capitalize (String.translate (fn ch => if ch = #"-" then "_" else str ch) s)
adam@1840 43
adamc@203 44 fun entable t =
adamc@203 45 case #1 t of
adamc@203 46 TRecord c => c
adamc@203 47 | _ => t
adamc@203 48
adamc@207 49 datatype select_item =
adamc@207 50 Field of con * con
adamc@1194 51 | Exp of con option * exp
adamc@341 52 | Fields of con * con
adam@1627 53 | StarFields of con
adamc@207 54
adamc@207 55 datatype select =
adamc@207 56 Star
adamc@207 57 | Items of select_item list
adamc@207 58
adamc@226 59 datatype group_item =
adamc@226 60 GField of con * con
adam@1425 61 | GFields of con * con
adamc@226 62
adamc@207 63 fun eqTnames ((c1, _), (c2, _)) =
adamc@207 64 case (c1, c2) of
adamc@207 65 (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2
adamc@207 66 | (CName x1, CName x2) => x1 = x2
adamc@207 67 | _ => false
adamc@207 68
adam@1424 69 fun nameString (c, _) =
adam@1424 70 case c of
adam@1424 71 CName s => s
adam@1424 72 | CVar (_, x) => x
adam@1424 73 | _ => "?"
adam@1424 74
adam@1627 75 datatype tableMode =
adam@1627 76 Unknown
adam@1627 77 | Everything
adam@1627 78 | Selective of con
adam@1627 79
adamc@1194 80 fun amend_select loc (si, (count, tabs, exps)) =
adamc@233 81 case si of
adamc@233 82 Field (tx, fx) =>
adamc@233 83 let
adamc@233 84 val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)
adamc@207 85
adamc@233 86 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@233 87 if eqTnames (tx, tx') then
adam@1627 88 case c' of
adam@1627 89 Everything =>
adam@1627 90 (ErrorMsg.errorAt loc
adam@1627 91 "Mixing specific-field and '*' selection of fields from same table";
adam@1627 92 ((tx', c'), found))
adam@1627 93 | Unknown =>
adam@1627 94 ((tx', Selective c), true)
adam@1627 95 | Selective c' =>
adam@1627 96 ((tx', Selective (CConcat (c, c'), loc)), true)
adamc@233 97 else
adamc@233 98 ((tx', c'), found))
adamc@233 99 false tabs
adamc@233 100 in
adamc@233 101 if found then
adamc@233 102 ()
adamc@233 103 else
adam@1424 104 ErrorMsg.errorAt loc ("Select of field " ^ nameString fx ^ " from unbound table " ^ nameString tx);
adamc@233 105
adamc@1194 106 (count, tabs, exps)
adamc@233 107 end
adamc@341 108 | Fields (tx, fs) =>
adamc@341 109 let
adamc@341 110 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@341 111 if eqTnames (tx, tx') then
adam@1627 112 case c' of
adam@1627 113 Everything =>
adam@1627 114 (ErrorMsg.errorAt loc
adam@1627 115 "Mixing specific-field and '*' selection of fields from same table";
adam@1627 116 ((tx', c'), found))
adam@1627 117 | Selective c' =>
adam@1627 118 ((tx', Selective (CConcat (fs, c'), loc)), true)
adam@1627 119 | Unknown =>
adam@1627 120 ((tx', Selective fs), true)
adamc@341 121 else
adamc@341 122 ((tx', c'), found))
adamc@341 123 false tabs
adamc@341 124 in
adamc@341 125 if found then
adamc@341 126 ()
adamc@341 127 else
adamc@341 128 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@341 129
adamc@1194 130 (count, tabs, exps)
adamc@341 131 end
adam@1627 132 | StarFields tx =>
adam@1627 133 if List.exists (fn (tx', c') => eqTnames (tx, tx') andalso case c' of
adam@1627 134 Unknown => false
adam@1627 135 | _ => true) tabs then
adam@1627 136 (ErrorMsg.errorAt loc "Selection with '*' from table already mentioned in same SELECT clause";
adam@1627 137 (count, tabs, exps))
adam@1627 138 else if List.all (fn (tx', c') => not (eqTnames (tx, tx'))) tabs then
adam@1627 139 (ErrorMsg.errorAt loc "Select of all fields from unbound table";
adam@1627 140 (count, tabs, exps))
adam@1627 141 else
adam@1627 142 (count, map (fn (tx', c') => (tx', if eqTnames (tx, tx') then Everything else c')) tabs, exps)
adamc@1194 143 | Exp (SOME c, e) => (count, tabs, (c, e) :: exps)
adamc@1194 144 | Exp (NONE, e) => (count+1, tabs, ((CName (Int.toString count), loc), e) :: exps)
adamc@207 145
adamc@226 146 fun amend_group loc (gi, tabs) =
adamc@226 147 let
adamc@226 148 val (tx, c) = case gi of
adamc@226 149 GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc))
adam@1425 150 | GFields (tx, fxs) => (tx, fxs)
adamc@226 151
adamc@226 152 val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
adamc@226 153 if eqTnames (tx, tx') then
adamc@226 154 ((tx', (CConcat (c, c'), loc)), true)
adamc@226 155 else
adamc@226 156 ((tx', c'), found))
adam@1425 157 false tabs
adamc@226 158 in
adamc@226 159 if found then
adamc@226 160 ()
adamc@226 161 else
adamc@226 162 ErrorMsg.errorAt loc "Select of field from unbound table";
adamc@226 163
adamc@226 164 tabs
adamc@226 165 end
adamc@226 166
adamc@403 167 fun sql_inject (v, loc) =
adamc@403 168 (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc)
adamc@209 169
adamc@220 170 fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
adamc@220 171 let
adamc@403 172 val e = (EVar (["Basis"], "sql_binary", Infer), loc)
adamc@403 173 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 174 val e = (EApp (e, sqlexp1), loc)
adamc@220 175 in
adamc@220 176 (EApp (e, sqlexp2), loc)
adamc@220 177 end
adamc@220 178
adamc@220 179 fun sql_unary (oper, sqlexp, loc) =
adamc@220 180 let
adamc@403 181 val e = (EVar (["Basis"], "sql_unary", Infer), loc)
adamc@403 182 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@220 183 in
adamc@220 184 (EApp (e, sqlexp), loc)
adamc@219 185 end
adamc@219 186
adam@1427 187 fun sql_relop (oper, all, sqlexp1, sqlexp2, loc) =
adamc@229 188 let
adamc@403 189 val e = (EVar (["Basis"], "sql_relop", Infer), loc)
adamc@403 190 val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adam@1427 191 val e = (EApp (e, (EVar (["Basis"], if all then "True" else "False", Infer), loc)), loc)
adamc@229 192 val e = (EApp (e, sqlexp1), loc)
adamc@229 193 in
adamc@229 194 (EApp (e, sqlexp2), loc)
adamc@229 195 end
adamc@229 196
adamc@441 197 fun sql_nfunc (oper, loc) =
adamc@441 198 let
adamc@441 199 val e = (EVar (["Basis"], "sql_nfunc", Infer), loc)
adamc@441 200 in
adamc@441 201 (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
adamc@441 202 end
adamc@441 203
adamc@389 204 fun native_unop (oper, e1, loc) =
adamc@389 205 let
adamc@403 206 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@389 207 in
adamc@389 208 (EApp (e, e1), loc)
adamc@389 209 end
adamc@389 210
adamc@256 211 fun native_op (oper, e1, e2, loc) =
adamc@256 212 let
adamc@403 213 val e = (EVar (["Basis"], oper, Infer), loc)
adamc@256 214 val e = (EApp (e, e1), loc)
adamc@256 215 in
adamc@256 216 (EApp (e, e2), loc)
adamc@256 217 end
adamc@256 218
adamc@310 219 val inDml = ref false
adamc@310 220
adamc@325 221 fun tagIn bt =
adamc@325 222 case bt of
adamc@325 223 "table" => "tabl"
adamc@325 224 | _ => bt
adamc@325 225
adamc@709 226 datatype prop_kind = Delete | Update
adamc@709 227
adam@2047 228 datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * string * exp
adamc@721 229
adamc@822 230 fun patType loc (p : pat) =
adamc@822 231 case #1 p of
adamc@822 232 PAnnot (_, t) => t
adamc@822 233 | _ => (CWild (KType, loc), loc)
adamc@822 234
adamc@1265 235 fun tnamesOf (e, _) =
adamc@1265 236 case e of
adamc@1265 237 EApp (e1, e2) => tnamesOf e1 @ tnamesOf e2
adamc@1265 238 | ECApp (e, c as (CName _, _)) =>
adamc@1265 239 let
adamc@1265 240 fun isFt (e, _) =
adamc@1265 241 case e of
adamc@1265 242 EVar (["Basis"], "sql_from_table", _) => true
adamc@1265 243 | EVar ([], "sql_from_table", _) => true
adamc@1265 244 | ECApp (e, _) => isFt e
adamc@1265 245 | EApp (e, _) => isFt e
adamc@1265 246 | EDisjointApp e => isFt e
adamc@1265 247 | _ => false
adamc@1265 248 in
adamc@1265 249 (if isFt e then [c] else []) @ tnamesOf e
adamc@1265 250 end
adamc@1265 251 | ECApp (e, _) => tnamesOf e
adamc@1265 252 | EDisjointApp e => tnamesOf e
adamc@1265 253 | _ => []
adamc@1265 254
adam@1761 255 fun classOut (s, pos) =
adam@1761 256 let
adam@1761 257 val s = case s of
adam@1761 258 "table" => "tabl"
adam@1761 259 | _ => s
adam@1761 260 in
adam@1761 261 (EVar ([], String.translate (fn #"-" => "_" | ch => str ch) s, Infer), pos)
adam@1761 262 end
adam@1749 263
adam@1749 264 fun parseClass s pos =
adam@1749 265 case String.tokens Char.isSpace s of
adam@1749 266 [] => (EVar (["Basis"], "null", Infer), pos)
adam@1749 267 | class :: classes =>
adam@1749 268 foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos))
adam@1749 269 (classOut (class, pos)) classes
adam@1749 270
adam@1750 271 fun parseValue s pos =
adam@1750 272 if String.isPrefix "url(" s andalso String.isSuffix ")" s then
adam@1750 273 let
adam@1750 274 val s = String.substring (s, 4, size s - 5)
adam@1750 275
adam@1750 276 val s = if size s >= 2
adam@1750 277 andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s)
adam@1750 278 orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then
adam@1750 279 String.substring (s, 1, size s - 2)
adam@1750 280 else
adam@1750 281 s
adam@1750 282 in
adam@1750 283 (EApp ((EVar (["Basis"], "css_url", Infer), pos),
adam@1750 284 (EApp ((EVar (["Basis"], "bless", Infer), pos),
adam@2048 285 (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)), pos)
adam@1750 286 end
adam@1750 287 else
adam@1750 288 (EApp ((EVar (["Basis"], "atom", Infer), pos),
adam@2048 289 (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)
adam@1750 290
adam@1750 291 fun parseProperty s pos =
adam@1750 292 let
adam@1750 293 val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s)
adam@1750 294 in
adam@1750 295 if Substring.isEmpty after then
adam@1750 296 (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s);
adam@2048 297 (EPrim (Prim.String (Prim.Normal, "")), pos))
adam@1750 298 else
adam@1750 299 foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos))
adam@1750 300 (EApp ((EVar (["Basis"], "property", Infer), pos),
adam@2048 301 (EPrim (Prim.String (Prim.Normal, Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos)
adam@1750 302 (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE))))
adam@1750 303 end
adam@1750 304
adam@1750 305 fun parseStyle s pos =
adam@1750 306 case String.tokens (fn ch => ch = #";") s of
adam@1750 307 [] => (EVar (["Basis"], "noStyle", Infer), pos)
adam@1750 308 | props =>
adam@1750 309 foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos))
adam@1750 310 (EVar (["Basis"], "noStyle", Infer), pos) props
adam@1750 311
adam@1777 312 fun applyWindow loc e window =
adam@1777 313 let
adam@1777 314 val (pb, ob) = getOpt (window, ((EVar (["Basis"], "sql_no_partition", Infer), dummy),
adam@1777 315 (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
adam@1777 316 (CWild (KRecord (KType, dummy), dummy), dummy)),
adam@1777 317 dummy)))
adam@1778 318 val e' = (EVar (["Basis"], "sql_window_function", Infer), loc)
adam@1777 319 val e' = (EApp (e', e), loc)
adam@1777 320 val e' = (EApp (e', pb), loc)
adam@1777 321 in
adam@1777 322 (EApp (e', ob), loc)
adam@1777 323 end
adam@1777 324
adam@2009 325 fun patternOut (e : exp) =
adam@2009 326 case #1 e of
adam@2009 327 EWild => (PWild, #2 e)
adam@2009 328 | EVar ([], x, Infer) =>
adam@2009 329 if Char.isUpper (String.sub (x, 0)) then
adam@2009 330 (PCon ([], x, NONE), #2 e)
adam@2009 331 else
adam@2009 332 (PVar x, #2 e)
adam@2009 333 | EVar (xs, x, Infer) =>
adam@2009 334 if Char.isUpper (String.sub (x, 0)) then
adam@2009 335 (PCon (xs, x, NONE), #2 e)
adam@2009 336 else
adam@2009 337 (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern";
adam@2009 338 (PWild, #2 e))
adam@2009 339 | EPrim p => (PPrim p, #2 e)
adam@2009 340 | EApp ((EVar (xs, x, Infer), _), e') =>
adam@2009 341 (PCon (xs, x, SOME (patternOut e')), #2 e)
adam@2009 342 | ERecord (xes, flex) =>
adam@2009 343 (PRecord (map (fn (x, e') =>
adam@2009 344 let
adam@2009 345 val x =
adam@2009 346 case #1 x of
adam@2009 347 CName x => x
adam@2009 348 | _ => (ErrorMsg.errorAt (#2 e) "Field name not constant in pattern";
adam@2009 349 "")
adam@2009 350 in
adam@2009 351 (x, patternOut e')
adam@2009 352 end) xes, flex), #2 e)
adam@2009 353 | EAnnot (e', t) =>
adam@2009 354 (PAnnot (patternOut e', t), #2 e)
adam@2009 355 | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern.";
adam@2009 356 (PWild, #2 e))
adam@2009 357
adamc@1 358 %%
adamc@244 359 %header (functor UrwebLrValsFn(structure Token : TOKEN))
adamc@1 360
adamc@1 361 %term
adamc@1 362 EOF
adamc@821 363 | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
adamc@1 364 | SYMBOL of string | CSYMBOL of string
adamc@1 365 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adam@1306 366 | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@403 367 | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
adam@2010 368 | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI
adamc@156 369 | DATATYPE | OF
adamc@7 370 | TYPE | NAME
adamc@629 371 | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
adamc@674 372 | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
adamc@446 373 | LET | IN
adam@1732 374 | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | SQL | SELECT1
adamc@754 375 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
adamc@1199 376 | COOKIE | STYLE | TASK | POLICY
adamc@842 377 | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
adamc@1 378
adamc@360 379 | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
adamc@91 380 | NOTAGS of string
adamc@91 381 | BEGIN_TAG of string | END_TAG of string
adamc@91 382
adamc@993 383 | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
adamc@229 384 | UNION | INTERSECT | EXCEPT
adamc@232 385 | LIMIT | OFFSET | ALL
adamc@220 386 | TRUE | FALSE | CAND | OR | NOT
adam@1778 387 | COUNT | AVG | SUM | MIN | MAX | RANK | PARTITION | OVER
adam@1682 388 | ASC | DESC | RANDOM
kkallio@1607 389 | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
adamc@441 390 | CURRENT_TIMESTAMP
adamc@219 391 | NE | LT | LE | GT | GE
adamc@714 392 | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
adamc@751 393 | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
kkallio@1572 394 | CIF | CTHEN | CELSE
adamc@204 395
adamc@30 396 %nonterm
adamc@1 397 file of decl list
adamc@1 398 | decls of decl list
adamc@325 399 | decl of decl list
adamc@123 400 | vali of string * con option * exp
adamc@123 401 | valis of (string * con option * exp) list
adamc@242 402 | copt of con option
adamc@1 403
adamc@191 404 | dargs of string list
adamc@156 405 | barOpt of unit
adamc@156 406 | dcons of (string * con option) list
adamc@805 407 | dtype of string * string list * (string * con option) list
adamc@805 408 | dtypes of (string * string list * (string * con option) list) list
adamc@156 409 | dcon of string * con option
adamc@156 410
adamc@707 411 | pkopt of exp
adam@1722 412 | pk of exp
adamc@707 413 | commaOpt of unit
adamc@707 414
adamc@704 415 | cst of exp
adamc@704 416 | csts of exp
adamc@704 417 | cstopt of exp
adamc@704 418
adamc@1001 419 | ckl of (string * kind option) list
adamc@1001 420
adamc@709 421 | pmode of prop_kind * exp
adamc@709 422 | pkind of prop_kind
adamc@709 423 | prule of exp
adamc@709 424 | pmodes of (prop_kind * exp) list
adamc@709 425
adamc@30 426 | sgn of sgn
adamc@42 427 | sgntm of sgn
adamc@30 428 | sgi of sgn_item
adamc@30 429 | sgis of sgn_item list
adamc@30 430
adamc@30 431 | str of str
adamc@30 432
adamc@1 433 | kind of kind
adamc@207 434 | ktuple of kind list
adamc@1 435 | kcolon of explicitness
adamc@240 436 | kopt of kind option
adamc@1 437
adamc@34 438 | path of string list * string
adamc@156 439 | cpath of string list * string
adamc@34 440 | spath of str
adamc@59 441 | mpath of string list
adamc@34 442
adamc@1 443 | cexp of con
adam@1577 444 | cexpO of con option
adamc@1 445 | capps of con
adamc@1 446 | cterm of con
adamc@195 447 | ctuple of con list
adamc@207 448 | ctuplev of con list
adamc@1 449 | ident of con
adamc@200 450 | idents of con list
adamc@1 451 | rcon of (con * con) list
adamc@83 452 | rconn of (con * con) list
adamc@1 453 | rcone of (con * con) list
adamc@239 454 | cargs of con * kind -> con * kind
adamc@239 455 | cargl of con * kind -> con * kind
adamc@240 456 | cargl2 of con * kind -> con * kind
adamc@239 457 | carg of con * kind -> con * kind
adamc@239 458 | cargp of con * kind -> con * kind
adamc@1 459
adamc@8 460 | eexp of exp
adamc@8 461 | eapps of exp
adamc@8 462 | eterm of exp
adamc@195 463 | etuple of exp list
adam@2009 464 | rexp of (con * exp) list * bool
adamc@91 465 | xml of exp
adamc@91 466 | xmlOne of exp
adamc@1045 467 | xmlOpt of exp
adam@1643 468 | tag of (string * exp) * exp option * exp option * exp
adamc@141 469 | tagHead of string * exp
adam@2009 470 | bind of pat * con option * exp
adamc@446 471 | edecl of edecl
adamc@446 472 | edecls of edecl list
adamc@8 473
adamc@241 474 | earg of exp * con -> exp * con
adamc@241 475 | eargp of exp * con -> exp * con
adamc@822 476 | earga of exp * con -> exp * con
adamc@241 477 | eargs of exp * con -> exp * con
adamc@241 478 | eargl of exp * con -> exp * con
adamc@242 479 | eargl2 of exp * con -> exp * con
adamc@241 480
adamc@170 481 | branch of pat * exp
adamc@170 482 | branchs of (pat * exp) list
adamc@170 483 | pat of pat
adamc@822 484 | patS of pat
adamc@170 485 | pterm of pat
adamc@174 486 | rpat of (string * pat) list * bool
adamc@195 487 | ptuple of pat list
adamc@170 488
adam@2047 489 | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
adamc@721 490 | attr of attr
adamc@104 491 | attrv of exp
adamc@104 492
adamc@204 493 | query of exp
adamc@226 494 | query1 of exp
adamc@993 495 | dopt of exp
adamc@748 496 | tables of con list * exp
adamc@749 497 | fitem of con list * exp
adamc@204 498 | tname of con
adamc@705 499 | tnameW of con * con
adamc@705 500 | tnames of (con * con) * (con * con) list
adamc@705 501 | tnames' of (con * con) * (con * con) list
adamc@204 502 | table of con * exp
adamc@748 503 | table' of con * exp
adamc@207 504 | tident of con
adamc@207 505 | fident of con
adamc@207 506 | seli of select_item
adamc@207 507 | selis of select_item list
adamc@207 508 | select of select
adamc@209 509 | sqlexp of exp
adam@1777 510 | window of (exp * exp) option
adam@1777 511 | pbopt of exp
adamc@209 512 | wopt of exp
adamc@226 513 | groupi of group_item
adamc@226 514 | groupis of group_item list
adamc@226 515 | gopt of group_item list option
adamc@227 516 | hopt of exp
adamc@230 517 | obopt of exp
adamc@268 518 | obitem of exp * exp
adamc@230 519 | obexps of exp
adam@1682 520 | popt of unit
adamc@268 521 | diropt of exp
adamc@231 522 | lopt of exp
adamc@232 523 | ofopt of exp
adamc@231 524 | sqlint of exp
adamc@236 525 | sqlagg of string
adamc@746 526 | fname of exp
adamc@207 527
adamc@302 528 | texp of exp
adamc@302 529 | fields of con list
adamc@302 530 | sqlexps of exp list
adamc@303 531 | fsets of (con * exp) list
adamc@310 532 | enterDml of unit
adamc@310 533 | leaveDml of unit
adamc@302 534
adam@2010 535 | ffi_mode of ffi_mode
adam@2010 536 | ffi_modes of ffi_mode list
adam@2010 537
adamc@204 538
adamc@1 539 %verbose (* print summary of errors *)
adamc@1 540 %pos int (* positions *)
adamc@1 541 %start file
adamc@1 542 %pure
adamc@1 543 %eop EOF
adamc@1 544 %noshift EOF
adamc@1 545
adamc@244 546 %name Urweb
adamc@1 547
adamc@623 548 %right KARROW
adamc@623 549 %nonassoc DKARROW
adamc@243 550 %right SEMI
adamc@243 551 %nonassoc LARROW
adamc@195 552 %nonassoc IF THEN ELSE
adamc@843 553 %nonassoc DARROW
adamc@842 554 %left ANDALSO
adamc@842 555 %left ORELSE
adamc@1 556 %nonassoc COLON
adam@1306 557 %nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD
adam@1427 558 %left UNION INTERSECT EXCEPT ALL
adamc@1 559 %right COMMA
adamc@751 560 %right JOIN INNER CROSS OUTER LEFT RIGHT FULL
adamc@220 561 %right OR
adamc@220 562 %right CAND
adamc@470 563 %nonassoc EQ NE LT LE GT GE IS
adamc@243 564 %right ARROW
adamc@837 565 %right CARET PLUSPLUS
adamc@837 566 %left MINUSMINUS MINUSMINUSMINUS
adamc@389 567 %left PLUS MINUS
adamc@389 568 %left STAR DIVIDE MOD
adamc@220 569 %left NOT
adamc@84 570 %nonassoc TWIDDLE
adamc@1 571 %nonassoc DOLLAR
adamc@1 572 %left DOT
adamc@221 573 %nonassoc LBRACE RBRACE
adamc@1 574
adamc@1 575 %%
adamc@1 576
adamc@1 577 file : decls (decls)
adamc@54 578 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54 579 s (SIGleft, sgisright))])
adamc@1 580
adamc@1 581 decls : ([])
adamc@325 582 | decl decls (decl @ decls)
adamc@1 583
adamc@240 584 decl : CON SYMBOL cargl2 kopt EQ cexp (let
adamc@240 585 val loc = s (CONleft, cexpright)
adamc@240 586
adamc@240 587 val k = Option.getOpt (kopt, (KWild, loc))
adamc@240 588 val (c, k) = cargl2 (cexp, k)
adamc@240 589 in
adamc@325 590 [(DCon (SYMBOL, SOME k, c), loc)]
adamc@240 591 end)
adam@1654 592 | LTYPE SYMBOL cargl2 EQ cexp (let
adam@1654 593 val loc = s (LTYPEleft, cexpright)
adam@1654 594
adam@1654 595 val k = (KWild, loc)
adam@1654 596 val (c, k) = cargl2 (cexp, k)
adam@1654 597 in
adam@1654 598 [(DCon (SYMBOL, SOME k, c), loc)]
adam@1654 599 end)
adamc@805 600 | DATATYPE dtypes ([(DDatatype dtypes, s (DATATYPEleft, dtypesright))])
adamc@191 601 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 602 (case dargs of
adamc@325 603 [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
adamc@191 604 | _ => raise Fail "Arguments specified for imported datatype")
adamc@325 605 | VAL vali ([(DVal vali, s (VALleft, valiright))])
adamc@325 606 | VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
adamc@325 607 | FUN valis ([(DValRec valis, s (FUNleft, valisright))])
adamc@1 608
adamc@325 609 | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
adam@1868 610 | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, NONE, str, false), s (STRUCTUREleft, strright))])
adam@1868 611 | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str, false), s (STRUCTUREleft, strright))])
adamc@42 612 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
adam@1732 613 ([(DStr (CSYMBOL1, NONE, NONE,
adam@1868 614 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright)), false),
adamc@325 615 s (FUNCTORleft, strright))])
adamc@42 616 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
adam@1732 617 ([(DStr (CSYMBOL1, NONE, NONE,
adam@1868 618 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)), false),
adamc@325 619 s (FUNCTORleft, strright))])
adamc@61 620 | OPEN mpath (case mpath of
adamc@61 621 [] => raise Fail "Impossible mpath parse [1]"
adamc@325 622 | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
adamc@325 623 | OPEN mpath LPAREN str RPAREN (let
adamc@325 624 val loc = s (OPENleft, RPARENright)
adamc@325 625
adamc@325 626 val m = case mpath of
adamc@325 627 [] => raise Fail "Impossible mpath parse [4]"
adamc@325 628 | m :: ms =>
adamc@325 629 foldl (fn (m, str) => (StrProj (str, m), loc))
adamc@325 630 (StrVar m, loc) ms
adamc@325 631 in
adam@1868 632 [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc), false), loc),
adamc@325 633 (DOpen ("anon", []), loc)]
adamc@325 634 end)
adamc@88 635 | OPEN CONSTRAINTS mpath (case mpath of
adamc@88 636 [] => raise Fail "Impossible mpath parse [3]"
adamc@325 637 | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
adamc@325 638 | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
adamc@325 639 | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))])
adamc@707 640 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt),
adamc@707 641 s (TABLEleft, cstoptright))])
adamc@338 642 | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
adamc@754 643 | VIEW SYMBOL EQ query ([(DView (SYMBOL, query),
adamc@754 644 s (VIEWleft, queryright))])
adamc@754 645 | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp),
adamc@754 646 s (VIEWleft, RBRACEright))])
adamc@459 647 | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
adamc@720 648 | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
adamc@1075 649 | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
adamc@1199 650 | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))])
adam@2010 651 | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))])
adamc@30 652
adamc@805 653 dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
adamc@805 654
adamc@805 655 dtypes : dtype ([dtype])
adamc@805 656 | dtype AND dtypes (dtype :: dtypes)
adamc@805 657
adamc@240 658 kopt : (NONE)
adamc@240 659 | DCOLON kind (SOME kind)
adam@1302 660 | DCOLONWILD (SOME (KWild, s (DCOLONWILDleft, DCOLONWILDright)))
adamc@240 661
adamc@191 662 dargs : ([])
adamc@191 663 | SYMBOL dargs (SYMBOL :: dargs)
adamc@191 664
adamc@156 665 barOpt : ()
adamc@156 666 | BAR ()
adamc@156 667
adamc@156 668 dcons : dcon ([dcon])
adamc@156 669 | dcon BAR dcons (dcon :: dcons)
adamc@156 670
adamc@156 671 dcon : CSYMBOL (CSYMBOL, NONE)
adamc@156 672 | CSYMBOL OF cexp (CSYMBOL, SOME cexp)
adamc@156 673
adamc@242 674 vali : SYMBOL eargl2 copt EQ eexp (let
adamc@242 675 val loc = s (SYMBOLleft, eexpright)
adamc@242 676 val t = Option.getOpt (copt, (CWild (KType, loc), loc))
adamc@242 677
adamc@242 678 val (e, t) = eargl2 (eexp, t)
adamc@242 679 in
adamc@242 680 (SYMBOL, SOME t, e)
adamc@242 681 end)
adamc@242 682
adamc@242 683 copt : (NONE)
adamc@242 684 | COLON cexp (SOME cexp)
adamc@123 685
adamc@704 686 cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy)
adamc@704 687 | csts (csts)
adamc@704 688
adamc@704 689 csts : CCONSTRAINT tname cst (let
adamc@704 690 val loc = s (CCONSTRAINTleft, cstright)
adamc@704 691
adamc@704 692 val e = (EVar (["Basis"], "one_constraint", Infer), loc)
adamc@704 693 val e = (ECApp (e, tname), loc)
adamc@704 694 in
adamc@704 695 (EApp (e, cst), loc)
adamc@704 696 end)
adamc@704 697 | csts COMMA csts (let
adamc@704 698 val loc = s (csts1left, csts2right)
adamc@704 699
adamc@704 700 val e = (EVar (["Basis"], "join_constraints", Infer), loc)
adamc@704 701 val e = (EApp (e, csts1), loc)
adamc@704 702 in
adamc@704 703 (EApp (e, csts2), loc)
adamc@704 704 end)
adamc@704 705 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adamc@704 706
adamc@704 707 cst : UNIQUE tnames (let
adamc@704 708 val loc = s (UNIQUEleft, tnamesright)
adamc@704 709
adamc@704 710 val e = (EVar (["Basis"], "unique", Infer), loc)
adamc@705 711 val e = (ECApp (e, #1 (#1 tnames)), loc)
adamc@705 712 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
adamc@704 713 in
adamc@1093 714 e
adamc@704 715 end)
adamc@709 716
adamc@714 717 | CHECK sqlexp (let
adamc@714 718 val loc = s (CHECKleft, sqlexpright)
adamc@714 719 in
adamc@714 720 (EApp ((EVar (["Basis"], "check", Infer), loc),
adamc@714 721 sqlexp), loc)
adamc@714 722 end)
adamc@714 723
adamc@709 724 | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
adamc@709 725 (let
adamc@709 726 val loc = s (FOREIGNleft, pmodesright)
adamc@709 727
adamc@709 728 val mat = ListPair.foldrEq
adamc@709 729 (fn ((nm1, _), (nm2, _), mat) =>
adamc@709 730 let
adamc@709 731 val e = (EVar (["Basis"], "mat_cons", Infer), loc)
adamc@709 732 val e = (ECApp (e, nm1), loc)
adamc@709 733 val e = (ECApp (e, nm2), loc)
adamc@709 734 in
adamc@709 735 (EApp (e, mat), loc)
adamc@709 736 end)
adamc@709 737 (EVar (["Basis"], "mat_nil", Infer), loc)
adamc@709 738 (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames')
adam@1401 739 handle ListPair.UnequalLengths =>
adam@1401 740 (ErrorMsg.errorAt loc ("Unequal foreign key list lengths ("
adam@1401 741 ^ Int.toString (1 + length (#2 tnames))
adam@1401 742 ^ " vs. "
adam@1401 743 ^ Int.toString (1 + length (#2 tnames'))
adam@1401 744 ^ ")");
adam@1401 745 (EVar (["Basis"], "mat_nil", Infer), loc))
adamc@709 746
adamc@709 747 fun findMode mode =
adamc@709 748 let
adamc@709 749 fun findMode' pmodes =
adamc@709 750 case pmodes of
adamc@709 751 [] => (EVar (["Basis"], "no_action", Infer), loc)
adamc@709 752 | (mode', rule) :: pmodes' =>
adamc@709 753 if mode' = mode then
adamc@709 754 (if List.exists (fn (mode', _) => mode' = mode)
adamc@709 755 pmodes' then
adamc@709 756 ErrorMsg.errorAt loc "Duplicate propagation rule"
adamc@709 757 else
adamc@709 758 ();
adamc@709 759 rule)
adamc@709 760 else
adamc@709 761 findMode' pmodes'
adamc@709 762 in
adamc@709 763 findMode' pmodes
adamc@709 764 end
adamc@709 765
adamc@709 766 val e = (EVar (["Basis"], "foreign_key", Infer), loc)
adamc@709 767 val e = (EApp (e, mat), loc)
adamc@709 768 val e = (EApp (e, texp), loc)
adamc@709 769 in
adam@2009 770 (EApp (e, (ERecord ([((CName "OnDelete", loc),
adam@2009 771 findMode Delete),
adam@2009 772 ((CName "OnUpdate", loc),
adam@2009 773 findMode Update)], false), loc)), loc)
adamc@709 774 end)
adamc@709 775
adamc@704 776 | LBRACE eexp RBRACE (eexp)
adamc@704 777
adamc@704 778 tnameW : tname (let
adamc@704 779 val loc = s (tnameleft, tnameright)
adamc@704 780 in
adamc@704 781 (tname, (CWild (KType, loc), loc))
adamc@704 782 end)
adamc@704 783
adamc@705 784 tnames : tnameW (tnameW, [])
adamc@705 785 | LPAREN tnames' RPAREN (tnames')
adamc@704 786
adamc@705 787 tnames': tnameW (tnameW, [])
adamc@705 788 | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames')
adamc@704 789
adamc@709 790 pmode : ON pkind prule (pkind, prule)
adamc@709 791
adamc@709 792 pkind : DELETE (Delete)
adamc@709 793 | UPDATE (Update)
adamc@709 794
adamc@709 795 prule : NO ACTION (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright))
adamc@709 796 | RESTRICT (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright))
adamc@709 797 | CASCADE (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright))
adamc@709 798 | SET NULL (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright))
adamc@709 799
adamc@709 800 pmodes : ([])
adamc@709 801 | pmode pmodes (pmode :: pmodes)
adamc@709 802
adamc@707 803 commaOpt: ()
adamc@707 804 | COMMA ()
adamc@707 805
adam@1722 806 pk : LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adam@1722 807 | tnames (let
adam@1722 808 val loc = s (tnamesleft, tnamesright)
adamc@707 809
adamc@1093 810 val e = (EVar (["Basis"], "primary_key", TypesOnly), loc)
adamc@707 811 val e = (ECApp (e, #1 (#1 tnames)), loc)
adamc@707 812 val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
adamc@707 813 val e = (EDisjointApp e, loc)
adamc@707 814 val e = (EDisjointApp e, loc)
adamc@707 815
adamc@707 816 val witness = map (fn (c, _) =>
adamc@707 817 (c, (EWild, loc)))
adamc@707 818 (#1 tnames :: #2 tnames)
adam@2009 819 val witness = (ERecord (witness, false), loc)
adamc@707 820 in
adamc@707 821 (EApp (e, witness), loc)
adamc@707 822 end)
adamc@707 823
adam@1722 824 pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy)
adam@1722 825 | PRIMARY KEY pk (pk)
adam@1722 826
adamc@123 827 valis : vali ([vali])
adamc@123 828 | vali AND valis (vali :: valis)
adamc@123 829
adamc@42 830 sgn : sgntm (sgntm)
adamc@40 831 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@40 832 (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
adamc@30 833
adamc@42 834 sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
adamc@59 835 | mpath (case mpath of
adamc@61 836 [] => raise Fail "Impossible mpath parse [2]"
adamc@59 837 | [x] => SgnVar x
adamc@59 838 | m :: ms => SgnProj (m,
adamc@59 839 List.take (ms, length ms - 1),
adamc@59 840 List.nth (ms, length ms - 1)),
adamc@59 841 s (mpathleft, mpathright))
adam@1864 842 | sgntm WHERE CON path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright))
adam@1864 843 | sgntm WHERE LTYPE path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright))
adamc@42 844 | LPAREN sgn RPAREN (sgn)
adamc@42 845
adam@1577 846 cexpO : (NONE)
adam@1577 847 | EQ cexp (SOME cexp)
adam@1577 848
adam@1577 849 sgi : LTYPE SYMBOL ((SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
adamc@706 850 s (LTYPEleft, SYMBOLright)))
adam@1577 851 | CON SYMBOL cargl2 kopt cexpO (let
adam@1577 852 val loc = s (CONleft, cexpOright)
adam@1574 853
adam@1574 854 val k = Option.getOpt (kopt, (KWild, loc))
adam@1574 855 in
adam@1577 856 case cexpO of
adam@1577 857 NONE => (SgiConAbs (SYMBOL, k), loc)
adam@1577 858 | SOME cexp =>
adam@1577 859 let
adam@1577 860 val (c, k) = cargl2 (cexp, k)
adam@1577 861 in
adam@1577 862 (SgiCon (SYMBOL, SOME k, c), loc)
adam@1577 863 end
adam@1574 864 end)
adam@1654 865 | LTYPE SYMBOL cargl2 cexpO (let
adam@1654 866 val loc = s (LTYPEleft, cexpOright)
adam@1654 867
adam@1654 868 val k = (KWild, loc)
adam@1654 869 in
adam@1654 870 case cexpO of
adam@1654 871 NONE => (SgiConAbs (SYMBOL, k), loc)
adam@1654 872 | SOME cexp =>
adam@1654 873 let
adam@1654 874 val (c, k) = cargl2 (cexp, k)
adam@1654 875 in
adam@1654 876 (SgiCon (SYMBOL, SOME k, c), loc)
adam@1654 877 end
adam@1654 878 end)
adamc@805 879 | DATATYPE dtypes ((SgiDatatype dtypes, s (DATATYPEleft, dtypesright)))
adamc@191 880 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
adamc@191 881 (case dargs of
adamc@191 882 [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@191 883 | _ => raise Fail "Arguments specified for imported datatype")
adamc@706 884 | VAL SYMBOL COLON cexp ((SgiVal (SYMBOL, cexp), s (VALleft, cexpright)))
adamc@30 885
adamc@706 886 | STRUCTURE CSYMBOL COLON sgn ((SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright)))
adamc@706 887 | SIGNATURE CSYMBOL EQ sgn ((SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)))
adamc@42 888 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@706 889 ((SgiStr (CSYMBOL1,
adamc@706 890 (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
adamc@706 891 s (FUNCTORleft, sgn2right)))
adamc@706 892 | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright)))
adamc@706 893 | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)))
adamc@707 894 | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let
adamc@707 895 val loc = s (TABLEleft, ctermright)
adamc@707 896 in
adamc@707 897 (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc)
adamc@707 898 end)
adamc@460 899 | SEQUENCE SYMBOL (let
adamc@460 900 val loc = s (SEQUENCEleft, SYMBOLright)
adamc@460 901 val t = (CVar (["Basis"], "sql_sequence"), loc)
adamc@460 902 in
adamc@460 903 (SgiVal (SYMBOL, t), loc)
adamc@460 904 end)
adamc@754 905 | VIEW SYMBOL COLON cexp (let
adamc@754 906 val loc = s (VIEWleft, cexpright)
adamc@754 907 val t = (CVar (["Basis"], "sql_view"), loc)
adamc@1076 908 val t = (CApp (t, entable cexp), loc)
adamc@754 909 in
adamc@754 910 (SgiVal (SYMBOL, t), loc)
adamc@754 911 end)
adamc@563 912 | CLASS SYMBOL (let
adamc@563 913 val loc = s (CLASSleft, SYMBOLright)
adamc@711 914 val k = (KArrow ((KType, loc), (KType, loc)), loc)
adamc@563 915 in
adamc@711 916 (SgiClassAbs (SYMBOL, k), loc)
adamc@563 917 end)
adamc@563 918 | CLASS SYMBOL DCOLON kind (let
adamc@563 919 val loc = s (CLASSleft, kindright)
adamc@563 920 in
adamc@563 921 (SgiClassAbs (SYMBOL, kind), loc)
adamc@563 922 end)
adamc@563 923 | CLASS SYMBOL EQ cexp (let
adamc@563 924 val loc = s (CLASSleft, cexpright)
adamc@563 925 in
adamc@563 926 (SgiClass (SYMBOL, (KWild, loc), cexp), loc)
adamc@563 927 end)
adamc@563 928 | CLASS SYMBOL DCOLON kind EQ cexp (let
adamc@563 929 val loc = s (CLASSleft, cexpright)
adamc@563 930 in
adamc@563 931 (SgiClass (SYMBOL, kind, cexp), loc)
adamc@563 932 end)
adamc@211 933 | CLASS SYMBOL SYMBOL EQ cexp (let
adamc@211 934 val loc = s (CLASSleft, cexpright)
adamc@563 935 val k = (KWild, loc)
adamc@211 936 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
adamc@211 937 in
adamc@563 938 (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright))
adamc@563 939 end)
adamc@563 940 | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let
adamc@563 941 val loc = s (CLASSleft, cexpright)
adamc@563 942 val c = (CAbs (SYMBOL2, SOME kind, cexp), loc)
adamc@563 943 in
adamc@563 944 (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))
adamc@211 945 end)
adamc@460 946 | COOKIE SYMBOL COLON cexp (let
adamc@460 947 val loc = s (COOKIEleft, cexpright)
adamc@460 948 val t = (CApp ((CVar (["Basis"], "http_cookie"), loc),
adamc@460 949 entable cexp), loc)
adamc@460 950 in
adamc@460 951 (SgiVal (SYMBOL, t), loc)
adamc@460 952 end)
adamc@720 953 | STYLE SYMBOL (let
adamc@720 954 val loc = s (STYLEleft, SYMBOLright)
adamc@720 955 val t = (CVar (["Basis"], "css_class"), loc)
adamc@718 956 in
adamc@718 957 (SgiVal (SYMBOL, t), loc)
adamc@718 958 end)
adamc@30 959
adamc@30 960 sgis : ([])
adamc@30 961 | sgi sgis (sgi :: sgis)
adamc@30 962
adamc@30 963 str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
adamc@34 964 | spath (spath)
adamc@40 965 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
adamc@40 966 (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
adamc@40 967 | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
adamc@40 968 (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
adamc@44 969 | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright))
adamc@34 970
adamc@34 971 spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@34 972 | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
adamc@30 973
adamc@1 974 kind : TYPE (KType, s (TYPEleft, TYPEright))
adamc@1 975 | NAME (KName, s (NAMEleft, NAMEright))
adamc@1 976 | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright))
adamc@1 977 | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right))
adamc@1 978 | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright))
adamc@82 979 | KUNIT (KUnit, s (KUNITleft, KUNITright))
adamc@18 980 | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright))
adamc@207 981 | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright))
adamc@623 982 | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@623 983 | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright))
adamc@207 984
adamc@207 985 ktuple : kind STAR kind ([kind1, kind2])
adamc@207 986 | kind STAR ktuple (kind :: ktuple)
adamc@1 987
adamc@1 988 capps : cterm (cterm)
adamc@1 989 | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright))
adamc@1 990
adamc@1 991 cexp : capps (capps)
adamc@1 992 | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
adamc@15 993 | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
adamc@623 994 | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
adamc@1 995
adamc@1 996 | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
adamc@1 997
adamc@239 998 | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
adamc@628 999 | LBRACK cexp TWIDDLE cexp RBRACK DARROW cexp (TDisjoint (cexp1, cexp2, cexp3), s (LBRACKleft, cexp3right))
adamc@623 1000 | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
adamc@1 1001
adamc@8 1002 | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
adamc@6 1003
adamc@18 1004 | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright))
adamc@195 1005 | ctuple (let
adamc@195 1006 val loc = s (ctupleleft, ctupleright)
adamc@195 1007 in
adamc@195 1008 (TRecord (CRecord (ListUtil.mapi (fn (i, c) =>
adamc@195 1009 ((CName (Int.toString (i + 1)), loc),
adamc@195 1010 c)) ctuple),
adamc@195 1011 loc), loc)
adamc@195 1012 end)
adamc@18 1013
adamc@1 1014 kcolon : DCOLON (Explicit)
adamc@1 1015 | TCOLON (Implicit)
adamc@1 1016
adamc@239 1017 cargs : carg (carg)
adamc@239 1018 | cargl (cargl)
adamc@239 1019
adamc@239 1020 cargl : cargp cargp (cargp1 o cargp2)
adamc@239 1021 | cargp cargl (cargp o cargl)
adamc@239 1022
adamc@240 1023 cargl2 : (fn x => x)
adamc@240 1024 | cargp cargl2 (cargp o cargl2)
adamc@240 1025
adamc@241 1026 carg : SYMBOL DCOLON kind (fn (c, k) =>
adamc@239 1027 let
adamc@239 1028 val loc = s (SYMBOLleft, kindright)
adamc@239 1029 in
adamc@239 1030 ((CAbs (SYMBOL, SOME kind, c), loc),
adamc@239 1031 (KArrow (kind, k), loc))
adamc@239 1032 end)
adamc@329 1033 | UNDER DCOLON kind (fn (c, k) =>
adamc@329 1034 let
adamc@329 1035 val loc = s (UNDERleft, kindright)
adamc@329 1036 in
adamc@329 1037 ((CAbs ("_", SOME kind, c), loc),
adamc@329 1038 (KArrow (kind, k), loc))
adamc@329 1039 end)
adam@1302 1040 | SYMBOL DCOLONWILD (fn (c, k) =>
adam@1302 1041 let
adam@1302 1042 val loc = s (SYMBOLleft, DCOLONWILDright)
adam@1302 1043 val kind = (KWild, loc)
adam@1302 1044 in
adam@1302 1045 ((CAbs (SYMBOL, NONE, c), loc),
adam@1302 1046 (KArrow (kind, k), loc))
adam@1302 1047 end)
adam@1302 1048 | UNDER DCOLONWILD (fn (c, k) =>
adam@1302 1049 let
adam@1302 1050 val loc = s (UNDERleft, DCOLONWILDright)
adam@1302 1051 val kind = (KWild, loc)
adam@1302 1052 in
adam@1302 1053 ((CAbs ("_", NONE, c), loc),
adam@1302 1054 (KArrow (kind, k), loc))
adam@1302 1055 end)
adamc@241 1056 | cargp (cargp)
adamc@239 1057
adamc@239 1058 cargp : SYMBOL (fn (c, k) =>
adamc@239 1059 let
adamc@239 1060 val loc = s (SYMBOLleft, SYMBOLright)
adamc@239 1061 in
adamc@239 1062 ((CAbs (SYMBOL, NONE, c), loc),
adamc@239 1063 (KArrow ((KWild, loc), k), loc))
adamc@239 1064 end)
adamc@329 1065 | UNDER (fn (c, k) =>
adamc@329 1066 let
adamc@329 1067 val loc = s (UNDERleft, UNDERright)
adamc@329 1068 in
adamc@329 1069 ((CAbs ("_", NONE, c), loc),
adamc@329 1070 (KArrow ((KWild, loc), k), loc))
adamc@329 1071 end)
adamc@1001 1072 | LPAREN SYMBOL kopt ckl RPAREN (fn (c, k) =>
adamc@239 1073 let
adamc@239 1074 val loc = s (LPARENleft, RPARENright)
adamc@1001 1075 val ckl = (SYMBOL, kopt) :: ckl
adamc@1001 1076 val ckl = map (fn (x, ko) => (x, case ko of
adamc@1001 1077 NONE => (KWild, loc)
adamc@1001 1078 | SOME k => k)) ckl
adamc@239 1079 in
adamc@1001 1080 case ckl of
adamc@1001 1081 [(x, k')] => ((CAbs (SYMBOL, SOME k', c), loc),
adamc@1001 1082 (KArrow (k', k), loc))
adamc@1001 1083 | _ =>
adamc@1001 1084 let
adamc@1001 1085 val k' = (KTuple (map #2 ckl), loc)
adamc@1001 1086
adamc@1001 1087 val c = foldr (fn ((x, k), c) =>
adamc@1001 1088 (CAbs (x, SOME k, c), loc)) c ckl
adamc@1001 1089 val v = (CVar ([], "$x"), loc)
adamc@1001 1090 val c = ListUtil.foldli (fn (i, _, c) =>
adamc@1001 1091 (CApp (c, (CProj (v, i + 1), loc)),
adamc@1001 1092 loc)) c ckl
adamc@1001 1093 in
adamc@1001 1094 ((CAbs ("$x", SOME k', c), loc),
adamc@1001 1095 (KArrow (k', k), loc))
adamc@1001 1096 end
adamc@239 1097 end)
adamc@628 1098
adamc@1001 1099 ckl : ([])
adamc@1001 1100 | COMMA SYMBOL kopt ckl ((SYMBOL, kopt) :: ckl)
adamc@239 1101
adamc@34 1102 path : SYMBOL ([], SYMBOL)
adamc@34 1103 | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
adamc@34 1104
adamc@156 1105 cpath : CSYMBOL ([], CSYMBOL)
adamc@156 1106 | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
adamc@156 1107
adamc@59 1108 mpath : CSYMBOL ([CSYMBOL])
adamc@59 1109 | CSYMBOL DOT mpath (CSYMBOL :: mpath)
adamc@59 1110
adamc@1 1111 cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright))
adamc@1 1112 | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright))
adamc@83 1113 | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright))
adamc@1 1114 | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
adamc@1 1115 s (LBRACEleft, RBRACEright))
adamc@1 1116 | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright))
adamc@1 1117 | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright))
adamc@195 1118 | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright))
adamc@1 1119
adamc@34 1120 | path (CVar path, s (pathleft, pathright))
adamc@207 1121 | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
adamc@207 1122 s (pathleft, INTright))
adamc@18 1123 | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
adamc@621 1124 | MAP (CMap, s (MAPleft, MAPright))
adamc@82 1125 | UNIT (CUnit, s (UNITleft, UNITright))
adamc@207 1126 | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright))
adamc@207 1127
adamc@207 1128 ctuplev: cexp COMMA cexp ([cexp1, cexp2])
adamc@207 1129 | cexp COMMA ctuplev (cexp :: ctuplev)
adamc@1 1130
adamc@196 1131 ctuple : capps STAR capps ([capps1, capps2])
adamc@196 1132 | capps STAR ctuple (capps :: ctuple)
adamc@195 1133
adamc@1 1134 rcon : ([])
adamc@1 1135 | ident EQ cexp ([(ident, cexp)])
adamc@1 1136 | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
adamc@1 1137
adamc@83 1138 rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
adamc@83 1139 | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
adamc@83 1140
adamc@1 1141 rcone : ([])
adamc@1 1142 | ident COLON cexp ([(ident, cexp)])
adamc@1 1143 | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
adamc@1 1144
adamc@1 1145 ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@195 1146 | INT (CName (Int64.toString INT), s (INTleft, INTright))
adamc@200 1147 | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@8 1148
adamc@8 1149 eapps : eterm (eterm)
adamc@8 1150 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
adamc@8 1151 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
adamc@629 1152 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
adamc@8 1153
adam@1751 1154 eexp : eapps (case #1 eapps of
adam@2048 1155 EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String (_, s)), loc)) => parseClass s loc
adam@2048 1156 | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String (_, s)), loc)) => parseStyle s loc
adam@1751 1157 | _ => eapps)
adamc@241 1158 | FN eargs DARROW eexp (let
adamc@93 1159 val loc = s (FNleft, eexpright)
adamc@93 1160 in
adamc@241 1161 #1 (eargs (eexp, (CWild (KType, loc), loc)))
adamc@93 1162 end)
adamc@623 1163 | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright))
adamc@196 1164 | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright))
adamc@149 1165 | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright))
adamc@493 1166 | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright))
adamc@170 1167 | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
adamc@190 1168 | IF eexp THEN eexp ELSE eexp (let
adamc@190 1169 val loc = s (IFleft, eexp3right)
adamc@190 1170 in
adamc@190 1171 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
adamc@190 1172 ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
adamc@190 1173 end)
adamc@434 1174 | bind SEMI eexp (let
adamc@434 1175 val loc = s (bindleft, eexpright)
adam@2009 1176 val (p, to, e1) = bind
adamc@403 1177 val e = (EVar (["Basis"], "bind", Infer), loc)
adamc@434 1178 val e = (EApp (e, e1), loc)
adam@2009 1179
adam@2009 1180 val f = case #1 p of
adam@2009 1181 PVar v => (EAbs (v, to, eexp), loc)
adam@2009 1182 | _ => (EAbs ("$x", to,
adam@2009 1183 (ECase ((EVar ([], "$x", Infer), loc),
adam@2009 1184 [(p, eexp)]), loc)), loc)
adamc@243 1185 in
adam@2009 1186 (EApp (e, f), loc)
adamc@299 1187 end)
adamc@256 1188 | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@257 1189 | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 1190 | MINUS eterm (native_unop ("neg", eterm, s (MINUSleft, etermright)))
adamc@389 1191 | eexp PLUS eexp (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 1192 | eexp MINUS eexp (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@1116 1193 | eapps STAR eexp (native_op ("times", eapps, eexp, s (eappsleft, eexpright)))
adamc@964 1194 | eexp DIVIDE eexp (native_op ("divide", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@389 1195 | eexp MOD eexp (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 1196
adamc@391 1197 | eexp LT eexp (native_op ("lt", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 1198 | eexp LE eexp (native_op ("le", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 1199 | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 1200 | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@391 1201
adamc@842 1202 | eexp ANDALSO eexp (let
adamc@842 1203 val loc = s (eexp1left, eexp2right)
adamc@842 1204 in
adamc@842 1205 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
adamc@842 1206 eexp2),
adamc@842 1207 ((PCon (["Basis"], "False", NONE), loc),
adamc@842 1208 (EVar (["Basis"], "False", Infer), loc))]), loc)
adamc@842 1209 end)
adamc@842 1210 | eexp ORELSE eexp (let
adamc@842 1211 val loc = s (eexp1left, eexp2right)
adamc@842 1212 in
adamc@842 1213 (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
adamc@842 1214 (EVar (["Basis"], "True", Infer), loc)),
adamc@842 1215 ((PCon (["Basis"], "False", NONE), loc),
adamc@842 1216 eexp2)]), loc)
adamc@842 1217 end)
adamc@842 1218
adamc@445 1219 | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
adamc@8 1220
adamc@674 1221 | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
adamc@674 1222
adamc@794 1223 | eapps DCOLON eexp (let
adamc@794 1224 val loc = s (eappsleft, eexpright)
adamc@762 1225 in
adamc@762 1226 (EApp ((EVar (["Basis"], "Cons", Infer), loc),
adam@2009 1227 (ERecord ([((CName "1", loc),
adam@2009 1228 eapps),
adam@2009 1229 ((CName "2", loc),
adam@2009 1230 eexp)], false), loc)), loc)
adamc@762 1231 end)
adamc@762 1232
adam@2009 1233 bind : eapps LARROW eapps (patternOut eapps1, NONE, eapps2)
adamc@434 1234 | eapps (let
adamc@434 1235 val loc = s (eappsleft, eappsright)
adamc@434 1236 in
adam@2009 1237 ((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps)
adamc@434 1238 end)
adamc@434 1239
adamc@241 1240 eargs : earg (earg)
adamc@241 1241 | eargl (eargl)
adamc@241 1242
adamc@241 1243 eargl : eargp eargp (eargp1 o eargp2)
adamc@241 1244 | eargp eargl (eargp o eargl)
adamc@241 1245
adamc@242 1246 eargl2 : (fn x => x)
adamc@242 1247 | eargp eargl2 (eargp o eargl2)
adamc@242 1248
adamc@822 1249 earg : patS (fn (e, t) =>
adamc@241 1250 let
adamc@822 1251 val loc = s (patSleft, patSright)
adamc@822 1252 val pt = patType loc patS
adamc@822 1253
adamc@822 1254 val e' = case #1 patS of
adamc@822 1255 PVar x => (EAbs (x, NONE, e), loc)
adamc@823 1256 | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc)
adamc@822 1257 | _ => (EAbs ("$x", SOME pt,
adamc@822 1258 (ECase ((EVar ([], "$x", DontInfer),
adamc@822 1259 loc),
adamc@822 1260 [(patS, e)]), loc)), loc)
adamc@241 1261 in
adamc@822 1262 (e', (TFun (pt, t), loc))
adamc@241 1263 end)
adamc@822 1264 | earga (earga)
adamc@822 1265
adamc@822 1266 eargp : pterm (fn (e, t) =>
adamc@241 1267 let
adamc@822 1268 val loc = s (ptermleft, ptermright)
adamc@822 1269 val pt = patType loc pterm
adamc@822 1270
adamc@822 1271 val e' = case #1 pterm of
adamc@822 1272 PVar x => (EAbs (x, NONE, e), loc)
adamc@823 1273 | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc)
adamc@822 1274 | _ => (EAbs ("$x", SOME pt,
adamc@822 1275 (ECase ((EVar ([], "$x", DontInfer),
adamc@822 1276 loc),
adamc@822 1277 [(pterm, e)]), loc)), loc)
adamc@241 1278 in
adamc@822 1279 (e', (TFun (pt, t), loc))
adamc@241 1280 end)
adamc@822 1281 | earga (earga)
adamc@241 1282
adamc@822 1283 earga : LBRACK SYMBOL RBRACK (fn (e, t) =>
adamc@241 1284 let
adamc@822 1285 val loc = s (LBRACKleft, RBRACKright)
adamc@822 1286 val kind = (KWild, loc)
adamc@822 1287 in
adamc@822 1288 ((ECAbs (Implicit, SYMBOL, kind, e), loc),
adamc@822 1289 (TCFun (Implicit, SYMBOL, kind, t), loc))
adamc@822 1290 end)
adam@1302 1291 | LBRACK SYMBOL DCOLONWILD RBRACK (fn (e, t) =>
adam@1302 1292 let
adam@1302 1293 val loc = s (LBRACKleft, RBRACKright)
adam@1302 1294 val kind = (KWild, loc)
adam@1302 1295 in
adam@1302 1296 ((ECAbs (Explicit, SYMBOL, kind, e), loc),
adam@1302 1297 (TCFun (Explicit, SYMBOL, kind, t), loc))
adam@1302 1298 end)
adamc@822 1299 | LBRACK SYMBOL kcolon kind RBRACK(fn (e, t) =>
adamc@822 1300 let
adamc@822 1301 val loc = s (LBRACKleft, RBRACKright)
adamc@241 1302 in
adamc@241 1303 ((ECAbs (kcolon, SYMBOL, kind, e), loc),
adamc@241 1304 (TCFun (kcolon, SYMBOL, kind, t), loc))
adamc@241 1305 end)
adam@1306 1306 | LBRACK SYMBOL TCOLONWILD RBRACK (fn (e, t) =>
adam@1306 1307 let
adam@1306 1308 val loc = s (LBRACKleft, RBRACKright)
adam@1306 1309 val kind = (KWild, loc)
adam@1306 1310 in
adam@1306 1311 ((ECAbs (Implicit, SYMBOL, kind, e), loc),
adam@1306 1312 (TCFun (Implicit, SYMBOL, kind, t), loc))
adam@1306 1313 end)
adamc@478 1314 | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) =>
adamc@356 1315 let
adamc@356 1316 val loc = s (LBRACKleft, RBRACKright)
adamc@356 1317 in
adamc@478 1318 ((EDisjoint (cexp1, cexp2, e), loc),
adamc@628 1319 (TDisjoint (cexp1, cexp2, t), loc))
adamc@356 1320 end)
adamc@822 1321 | LBRACK CSYMBOL RBRACK (fn (e, t) =>
adamc@623 1322 let
adamc@623 1323 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@623 1324 in
adamc@623 1325 ((EKAbs (CSYMBOL, e), loc),
adamc@623 1326 (TKFun (CSYMBOL, t), loc))
adamc@623 1327 end)
adamc@241 1328
adamc@8 1329 eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
adamc@195 1330 | LPAREN etuple RPAREN (let
adamc@195 1331 val loc = s (LPARENleft, RPARENright)
adamc@195 1332 in
adamc@195 1333 (ERecord (ListUtil.mapi (fn (i, e) =>
adamc@195 1334 ((CName (Int.toString (i + 1)), loc),
adam@2009 1335 e)) etuple, false), loc)
adamc@195 1336 end)
adamc@8 1337
adamc@403 1338 | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
adamc@403 1339 | cpath (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright))
adamc@403 1340 | AT path (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright))
adamc@403 1341 | AT AT path (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright))
adamc@403 1342 | AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
adamc@403 1343 | AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
adamc@12 1344 | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
adam@2009 1345 | LBRACE RBRACE (ERecord ([], false), s (LBRACEleft, RBRACEright))
adam@2009 1346 | UNIT (ERecord ([], false), s (UNITleft, UNITright))
adamc@12 1347
adamc@14 1348 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@14 1349 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adam@2048 1350 | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
adamc@821 1351 | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
adamc@14 1352
adamc@200 1353 | path DOT idents (let
adamc@200 1354 val loc = s (pathleft, identsright)
adamc@200 1355 in
adamc@200 1356 foldl (fn (ident, e) =>
adamc@200 1357 (EField (e, ident), loc))
adamc@403 1358 (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents
adamc@403 1359 end)
adamc@910 1360 | LPAREN eexp RPAREN DOT idents (let
adamc@910 1361 val loc = s (LPARENleft, identsright)
adamc@910 1362 in
adamc@910 1363 foldl (fn (ident, e) =>
adamc@910 1364 (EField (e, ident), loc))
adamc@910 1365 eexp idents
adamc@910 1366 end)
adamc@403 1367 | AT path DOT idents (let
adamc@403 1368 val loc = s (ATleft, identsright)
adamc@403 1369 in
adamc@403 1370 foldl (fn (ident, e) =>
adamc@403 1371 (EField (e, ident), loc))
adamc@403 1372 (EVar (#1 path, #2 path, TypesOnly), s (pathleft, pathright)) idents
adamc@403 1373 end)
adamc@403 1374 | AT AT path DOT idents (let
adamc@403 1375 val loc = s (AT1left, identsright)
adamc@403 1376 in
adamc@403 1377 foldl (fn (ident, e) =>
adamc@403 1378 (EField (e, ident), loc))
adamc@403 1379 (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents
adamc@200 1380 end)
adamc@71 1381
adamc@360 1382 | XML_BEGIN xml XML_END (let
adamc@360 1383 val loc = s (XML_BEGINleft, XML_ENDright)
adamc@360 1384 in
adamc@360 1385 if XML_BEGIN = "xml" then
adamc@360 1386 ()
adamc@360 1387 else
adamc@360 1388 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@360 1389 xml
adamc@360 1390 end)
adamc@360 1391 | XML_BEGIN XML_END (let
adamc@360 1392 val loc = s (XML_BEGINleft, XML_ENDright)
adamc@360 1393 in
adamc@360 1394 if XML_BEGIN = "xml" then
adamc@360 1395 ()
adamc@360 1396 else
adamc@360 1397 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@403 1398 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
adam@2048 1399 (EPrim (Prim.String (Prim.Html, "")), loc)),
adamc@360 1400 loc)
adamc@360 1401 end)
adamc@360 1402 | XML_BEGIN_END (let
adamc@360 1403 val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
adamc@360 1404 in
adamc@360 1405 if XML_BEGIN_END = "xml" then
adamc@360 1406 ()
adamc@360 1407 else
adamc@360 1408 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
adamc@403 1409 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
adam@2048 1410 (EPrim (Prim.String (Prim.Html, "")), loc)),
adamc@360 1411 loc)
adamc@360 1412 end)
adamc@302 1413
adamc@204 1414 | LPAREN query RPAREN (query)
adamc@300 1415 | LPAREN CWHERE sqlexp RPAREN (sqlexp)
adamc@339 1416 | LPAREN SQL sqlexp RPAREN (sqlexp)
adamc@1070 1417 | LPAREN FROM tables RPAREN (#2 tables)
adamc@1071 1418 | LPAREN SELECT1 query1 RPAREN (query1)
adamc@302 1419
adamc@302 1420 | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
adamc@302 1421 (let
adamc@302 1422 val loc = s (LPAREN1left, RPAREN3right)
adamc@302 1423
adamc@403 1424 val e = (EVar (["Basis"], "insert", Infer), loc)
adamc@302 1425 val e = (EApp (e, texp), loc)
adamc@302 1426 in
adamc@302 1427 if length fields <> length sqlexps then
adam@1360 1428 ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification ("
adam@1360 1429 ^ Int.toString (length fields)
adam@1360 1430 ^ " vs. " ^ Int.toString (length sqlexps) ^ ")")
adamc@302 1431 else
adamc@302 1432 ();
adam@2009 1433 (EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc)
adamc@302 1434 end)
adamc@310 1435 | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
adamc@303 1436 (let
adamc@303 1437 val loc = s (LPARENleft, RPARENright)
adamc@303 1438
adamc@403 1439 val e = (EVar (["Basis"], "update", Infer), loc)
adamc@342 1440 val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
adam@2009 1441 val e = (EApp (e, (ERecord (fsets, false), loc)), loc)
adamc@305 1442 val e = (EApp (e, texp), loc)
adamc@303 1443 in
adamc@303 1444 (EApp (e, sqlexp), loc)
adamc@303 1445 end)
adamc@310 1446 | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN
adamc@304 1447 (let
adamc@304 1448 val loc = s (LPARENleft, RPARENright)
adamc@304 1449
adamc@403 1450 val e = (EVar (["Basis"], "delete", Infer), loc)
adamc@304 1451 val e = (EApp (e, texp), loc)
adamc@304 1452 in
adamc@304 1453 (EApp (e, sqlexp), loc)
adamc@304 1454 end)
adamc@302 1455
adamc@211 1456 | UNDER (EWild, s (UNDERleft, UNDERright))
adamc@91 1457
adamc@446 1458 | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright))
adam@2025 1459 | LET eexp WHERE edecls END (ELet (edecls, eexp), s (LETleft, ENDright))
adamc@446 1460
adamc@762 1461 | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright))
adamc@762 1462
adamc@446 1463 edecls : ([])
adamc@446 1464 | edecl edecls (edecl :: edecls)
adamc@446 1465
adamc@825 1466 edecl : VAL pat EQ eexp ((EDVal (pat, eexp), s (VALleft, eexpright)))
adamc@446 1467 | VAL REC valis ((EDValRec valis, s (VALleft, valisright)))
adamc@446 1468 | FUN valis ((EDValRec valis, s (FUNleft, valisright)))
adamc@446 1469
adamc@310 1470 enterDml : (inDml := true)
adamc@310 1471 leaveDml : (inDml := false)
adamc@310 1472
adamc@403 1473 texp : SYMBOL (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
adamc@302 1474 | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
adamc@302 1475
adamc@302 1476 fields : fident ([fident])
adamc@302 1477 | fident COMMA fields (fident :: fields)
adamc@302 1478
adamc@302 1479 sqlexps: sqlexp ([sqlexp])
adamc@302 1480 | sqlexp COMMA sqlexps (sqlexp :: sqlexps)
adamc@302 1481
adamc@303 1482 fsets : fident EQ sqlexp ([(fident, sqlexp)])
adamc@303 1483 | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets)
adamc@303 1484
adamc@200 1485 idents : ident ([ident])
adamc@200 1486 | ident DOT idents (ident :: idents)
adamc@200 1487
adamc@195 1488 etuple : eexp COMMA eexp ([eexp1, eexp2])
adamc@195 1489 | eexp COMMA etuple (eexp :: etuple)
adamc@195 1490
adamc@170 1491 branch : pat DARROW eexp (pat, eexp)
adamc@170 1492
adamc@170 1493 branchs: ([])
adamc@170 1494 | BAR branch branchs (branch :: branchs)
adamc@170 1495
adamc@822 1496 patS : pterm (pterm)
adamc@822 1497 | pterm DCOLON patS (let
adamc@822 1498 val loc = s (ptermleft, patSright)
adamc@762 1499 in
adamc@762 1500 (PCon (["Basis"], "Cons", SOME (PRecord ([("1", pterm),
adamc@822 1501 ("2", patS)], false), loc)),
adamc@762 1502 loc)
adamc@762 1503 end)
adamc@822 1504 | patS COLON cexp (PAnnot (patS, cexp), s (patSleft, cexpright))
adamc@822 1505
adamc@822 1506 pat : patS (patS)
adamc@822 1507 | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
adamc@170 1508
adamc@170 1509 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@170 1510 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
adamc@170 1511 | UNDER (PWild, s (UNDERleft, UNDERright))
adamc@173 1512 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
adam@1420 1513 | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright))
adam@2048 1514 | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
adamc@821 1515 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
adamc@170 1516 | LPAREN pat RPAREN (pat)
adamc@174 1517 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
adamc@174 1518 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
adamc@174 1519 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
adamc@195 1520 | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple,
adamc@195 1521 false),
adamc@195 1522 s (LPARENleft, RPARENright))
adamc@762 1523 | LBRACK RBRACK (PCon (["Basis"], "Nil", NONE), s (LBRACKleft, RBRACKright))
adamc@174 1524
adamc@175 1525 rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
adamc@243 1526 | INT EQ pat ([(Int64.toString INT, pat)], false)
adamc@174 1527 | DOTDOTDOT ([], true)
adamc@175 1528 | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
adamc@243 1529 | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat)
adamc@170 1530
adamc@195 1531 ptuple : pat COMMA pat ([pat1, pat2])
adamc@195 1532 | pat COMMA ptuple (pat :: ptuple)
adamc@195 1533
adam@2009 1534 rexp : DOTDOTDOT ([], true)
adam@2009 1535 | ident EQ eexp ([(ident, eexp)], false)
adam@2009 1536 | ident EQ eexp COMMA rexp ((ident, eexp) :: #1 rexp, #2 rexp)
adamc@91 1537
adamc@141 1538 xml : xmlOne xml (let
adamc@141 1539 val pos = s (xmlOneleft, xmlright)
adamc@141 1540 in
adamc@720 1541 (EApp ((EApp (
adamc@720 1542 (EVar (["Basis"], "join", Infer), pos),
adamc@720 1543 xmlOne), pos),
adamc@720 1544 xml), pos)
adamc@141 1545 end)
adamc@141 1546 | xmlOne (xmlOne)
adamc@91 1547
adamc@1045 1548 xmlOpt : xml (xml)
adamc@1045 1549 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy),
adam@2048 1550 (EPrim (Prim.String (Prim.Html, "")), dummy)),
adamc@1045 1551 dummy)
adamc@1045 1552
adamc@403 1553 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
adam@2048 1554 (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))),
adamc@141 1555 s (NOTAGSleft, NOTAGSright))
adamc@141 1556 | tag DIVIDE GT (let
adamc@141 1557 val pos = s (tagleft, GTright)
adamc@710 1558
adamc@710 1559 val cdata =
adamc@756 1560 if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then
adamc@710 1561 let
adamc@710 1562 val e = (EVar (["Basis"], "cdata", DontInfer), pos)
adamc@710 1563 val e = (ECApp (e, (CWild (KWild, pos), pos)), pos)
adamc@710 1564 in
adamc@710 1565 (ECApp (e, (CRecord [], pos)), pos)
adamc@710 1566 end
adamc@710 1567 else
adamc@710 1568 (EVar (["Basis"], "cdata", Infer), pos)
adamc@710 1569
adamc@710 1570 val cdata = (EApp (cdata,
adam@2048 1571 (EPrim (Prim.String (Prim.Html, "")), pos)),
adamc@710 1572 pos)
adamc@141 1573 in
adam@1643 1574 (EApp (#4 tag, cdata), pos)
adamc@141 1575 end)
adamc@141 1576
adamc@1045 1577 | tag GT xmlOpt END_TAG (let
adam@1563 1578 fun tagOut s =
adam@1563 1579 case s of
adam@1563 1580 "tabl" => "table"
adam@1563 1581 | _ => s
adam@1563 1582
adamc@141 1583 val pos = s (tagleft, GTright)
adamc@325 1584 val et = tagIn END_TAG
adamc@141 1585 in
adamc@756 1586 if #1 (#1 tag) = et then
adamc@361 1587 if et = "form" then
adam@1412 1588 let
adam@1412 1589 val e = (EVar (["Basis"], "form", Infer), pos)
adam@1412 1590 val e = (EApp (e, case #2 tag of
adam@1412 1591 NONE => (EVar (["Basis"], "None", Infer), pos)
adam@1412 1592 | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
adam@1412 1593 in
adam@1651 1594 case #3 tag of
adam@1651 1595 NONE => ()
adam@1651 1596 | SOME _ => ErrorMsg.errorAt pos "<form> does not support 'dynClass' attribute";
adam@1412 1597 (EApp (e, xmlOpt), pos)
adam@1412 1598 end
adamc@1093 1599 else if et = "subform" orelse et = "subforms" then
adamc@1093 1600 (EApp (#2 (#1 tag),
adamc@1045 1601 xmlOpt), pos)
adamc@758 1602 else if et = "entry" then
adamc@758 1603 (EApp ((EVar (["Basis"], "entry", Infer), pos),
adamc@1045 1604 xmlOpt), pos)
adamc@141 1605 else
adam@1643 1606 (EApp (#4 tag, xmlOpt), pos)
adamc@141 1607 else
adamc@325 1608 (if ErrorMsg.anyErrors () then
adamc@325 1609 ()
adamc@325 1610 else
adamc@1189 1611 ErrorMsg.errorAt pos ("Begin tag <"
adam@1563 1612 ^ tagOut (#1 (#1 tag))
adamc@1189 1613 ^ "> and end tag </"
adam@1563 1614 ^ tagOut et
adamc@1189 1615 ^ "> don't match.");
adamc@623 1616 (EWild, pos))
adamc@141 1617 end)
adamc@141 1618 | LBRACE eexp RBRACE (eexp)
adamc@391 1619 | LBRACE LBRACK eexp RBRACK RBRACE (let
adamc@391 1620 val loc = s (LBRACEleft, RBRACEright)
adamc@403 1621 val e = (EVar (["Top"], "txt", Infer), loc)
adamc@391 1622 in
adamc@391 1623 (EApp (e, eexp), loc)
adamc@391 1624 end)
adamc@92 1625
adamc@141 1626 tag : tagHead attrs (let
adamc@141 1627 val pos = s (tagHeadleft, attrsright)
adamc@721 1628
adamc@721 1629 val e = (EVar (["Basis"], "tag", Infer), pos)
adamc@721 1630 val eo = case #1 attrs of
adam@1749 1631 NONE => (EVar (["Basis"], "null", Infer), pos)
adam@2048 1632 | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos
adam@1749 1633 | SOME e => e
adamc@721 1634 val e = (EApp (e, eo), pos)
adam@1643 1635 val eo = case #2 attrs of
adam@1643 1636 NONE => (EVar (["Basis"], "None", Infer), pos)
adam@1643 1637 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
adam@1643 1638 e), pos)
adam@1643 1639 val e = (EApp (e, eo), pos)
adam@1750 1640 val eo = case #3 attrs of
adam@1750 1641 NONE => (EVar (["Basis"], "noStyle", Infer), pos)
adam@2048 1642 | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos
adam@1750 1643 | SOME e => e
adam@1750 1644 val e = (EApp (e, eo), pos)
adam@1751 1645 val eo = case #4 attrs of
adam@1751 1646 NONE => (EVar (["Basis"], "None", Infer), pos)
adam@1751 1647 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
adam@1751 1648 e), pos)
adam@1751 1649 val e = (EApp (e, eo), pos)
adam@2008 1650
adam@2008 1651 val atts = case #5 attrs of
adam@2008 1652 [] => #6 attrs
adam@2008 1653 | data :: datas =>
adam@2008 1654 let
adam@2047 1655 fun doOne (kind, name, value) =
adam@2008 1656 let
adam@2008 1657 val e = (EVar (["Basis"], "data_attr", Infer), pos)
adam@2047 1658 val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos)
adam@2048 1659 val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos)
adam@2008 1660 in
adam@2008 1661 (EApp (e, value), pos)
adam@2008 1662 end
adam@2008 1663
adam@2008 1664 val datas' = foldl (fn (nv, acc) =>
adam@2008 1665 let
adam@2008 1666 val e = (EVar (["Basis"], "data_attrs", Infer), pos)
adam@2008 1667 val e = (EApp (e, acc), pos)
adam@2008 1668 in
adam@2008 1669 (EApp (e, doOne nv), pos)
adam@2008 1670 end) (doOne data) datas
adam@2008 1671 in
adam@2008 1672 ((CName "Data", pos), datas') :: #6 attrs
adam@2008 1673 end
adam@2008 1674
adam@2009 1675 val e = (EApp (e, (ERecord (atts, false), pos)), pos)
adamc@721 1676 val e = (EApp (e, (EApp (#2 tagHead,
adam@2009 1677 (ERecord ([], false), pos)), pos)), pos)
adamc@141 1678 in
adam@1643 1679 (tagHead, #1 attrs, #2 attrs, e)
adamc@141 1680 end)
adamc@141 1681
adamc@141 1682 tagHead: BEGIN_TAG (let
adamc@325 1683 val bt = tagIn BEGIN_TAG
adamc@141 1684 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141 1685 in
adamc@325 1686 (bt,
adam@1833 1687 (EVar ([], bt, Infer), pos))
adamc@141 1688 end)
adamc@141 1689 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92 1690
adam@2008 1691 attrs : (NONE, NONE, NONE, NONE, [], [])
adamc@721 1692 | attr attrs (let
adamc@721 1693 val loc = s (attrleft, attrsright)
adamc@721 1694 in
adamc@721 1695 case attr of
adamc@721 1696 Class e =>
adamc@721 1697 (case #1 attrs of
adamc@721 1698 NONE => ()
adamc@721 1699 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
adam@2008 1700 (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
adam@1643 1701 | DynClass e =>
adam@1643 1702 (case #2 attrs of
adam@1643 1703 NONE => ()
adam@1643 1704 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
adam@2008 1705 (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
adam@1750 1706 | Style e =>
adam@1750 1707 (case #3 attrs of
adam@1750 1708 NONE => ()
adam@1750 1709 | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
adam@2008 1710 (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
adam@1751 1711 | DynStyle e =>
adam@1751 1712 (case #4 attrs of
adam@1751 1713 NONE => ()
adam@1751 1714 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
adam@2008 1715 (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
adam@2008 1716 | Data xe =>
adam@2008 1717 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
adamc@721 1718 | Normal xe =>
adam@2008 1719 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
adamc@721 1720 end)
adamc@104 1721
adam@1643 1722 attr : SYMBOL EQ attrv (case SYMBOL of
adam@1643 1723 "class" => Class attrv
adam@1643 1724 | "dynClass" => DynClass attrv
adam@1750 1725 | "style" => Style attrv
adam@1751 1726 | "dynStyle" => DynStyle attrv
adam@1643 1727 | _ =>
adam@2008 1728 if String.isPrefix "data-" SYMBOL then
adam@2047 1729 Data ("data", String.extract (SYMBOL, 5, NONE), attrv)
adam@2047 1730 else if String.isPrefix "aria-" SYMBOL then
adam@2047 1731 Data ("aria", String.extract (SYMBOL, 5, NONE), attrv)
adam@2008 1732 else
adam@2008 1733 let
adam@2008 1734 val sym = makeAttr SYMBOL
adam@2008 1735 in
adam@2008 1736 Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
adam@2008 1737 if (sym = "Href" orelse sym = "Src")
adam@2008 1738 andalso (case #1 attrv of
adam@2008 1739 EPrim _ => true
adam@2008 1740 | _ => false) then
adam@2008 1741 let
adam@2008 1742 val loc = s (attrvleft, attrvright)
adam@2008 1743 in
adam@2008 1744 (EApp ((EVar (["Basis"], "bless", Infer), loc),
adam@2008 1745 attrv), loc)
adam@2008 1746 end
adam@2008 1747 else
adam@2008 1748 attrv)
adam@2008 1749 end)
adamc@204 1750
adamc@104 1751 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104 1752 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adam@2048 1753 | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
adamc@110 1754 | LBRACE eexp RBRACE (eexp)
adamc@226 1755
adamc@232 1756 query : query1 obopt lopt ofopt (let
adamc@229 1757 val loc = s (query1left, query1right)
adamc@230 1758
adam@2009 1759 val re = (ERecord ([((CName "Rows", loc),
adam@2009 1760 query1),
adam@2009 1761 ((CName "OrderBy", loc),
adam@2009 1762 obopt),
adam@2009 1763 ((CName "Limit", loc),
adam@2009 1764 lopt),
adam@2009 1765 ((CName "Offset", loc),
adam@2009 1766 ofopt)], false), loc)
adamc@229 1767 in
adamc@403 1768 (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
adamc@229 1769 end)
adamc@993 1770
adamc@993 1771 dopt : (EVar (["Basis"], "False", Infer), dummy)
adamc@993 1772 | DISTINCT (EVar (["Basis"], "True", Infer),
adamc@993 1773 s (DISTINCTleft, DISTINCTright))
adamc@993 1774
adamc@993 1775 query1 : SELECT dopt select FROM tables wopt gopt hopt
adamc@209 1776 (let
adamc@204 1777 val loc = s (SELECTleft, tablesright)
adamc@207 1778
adamc@1070 1779 val (empties, sel, exps) =
adamc@207 1780 case select of
adamc@1070 1781 Star => ([],
adamc@1070 1782 map (fn nm =>
adamc@233 1783 (nm, (CTuple [(CWild (KRecord (KType, loc), loc),
adamc@233 1784 loc),
adamc@233 1785 (CRecord [], loc)],
adamc@748 1786 loc))) (#1 tables),
adamc@233 1787 [])
adamc@207 1788 | Items sis =>
adamc@207 1789 let
adam@1627 1790 val tabs = map (fn nm => (nm, Unknown)) (#1 tables)
adamc@1194 1791 val (_, tabs, exps) = foldl (amend_select loc)
adamc@1194 1792 (1, tabs, []) sis
adam@1627 1793 val empties = List.mapPartial (fn (nm, c) =>
adam@1627 1794 case c of
adam@1627 1795 Unknown => SOME nm
adam@1627 1796 | Selective (CRecord [], _) => SOME nm
adam@1627 1797 | _ => NONE) tabs
adamc@207 1798 in
adamc@1070 1799 (empties,
adamc@1070 1800 map (fn (nm, c) => (nm,
adam@1627 1801 case c of
adam@1627 1802 Everything =>
adam@1627 1803 (CTuple [(CWild (KRecord (KType, loc), loc), loc),
adam@1627 1804 (CRecord [], loc)], loc)
adam@1627 1805 | _ =>
adam@1627 1806 let
adam@1627 1807 val c = case c of
adam@1627 1808 Selective c => c
adam@1627 1809 | _ => (CRecord [], loc)
adam@1627 1810 in
adam@1627 1811 (CTuple [c,
adam@1627 1812 (CWild (KRecord (KType, loc), loc),
adam@1627 1813 loc)], loc)
adam@1627 1814 end)) tabs,
adamc@233 1815 exps)
adamc@207 1816 end
adamc@207 1817
adam@1778 1818 val exps = map (fn (c, e) => (c, (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc))) exps
adam@1778 1819
adamc@207 1820 val sel = (CRecord sel, loc)
adamc@207 1821
adamc@226 1822 val grp = case gopt of
adamc@403 1823 NONE => (ECApp ((EVar (["Basis"], "sql_subset_all",
adamc@403 1824 Infer), loc),
adamc@226 1825 (CWild (KRecord (KRecord (KType, loc), loc),
adamc@226 1826 loc), loc)), loc)
adamc@226 1827 | SOME gis =>
adamc@226 1828 let
adamc@748 1829 val tabs = map (fn nm =>
adamc@748 1830 (nm, (CRecord [], loc))) (#1 tables)
adamc@226 1831 val tabs = foldl (amend_group loc) tabs gis
adamc@226 1832
adamc@226 1833 val tabs = map (fn (nm, c) =>
adamc@226 1834 (nm,
adamc@226 1835 (CTuple [c,
adamc@226 1836 (CWild (KRecord (KType, loc),
adamc@226 1837 loc),
adamc@226 1838 loc)], loc))) tabs
adamc@226 1839 in
adamc@403 1840 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adamc@226 1841 (CRecord tabs, loc)), loc)
adamc@226 1842 end
adamc@226 1843
adamc@403 1844 val e = (EVar (["Basis"], "sql_query1", Infer), loc)
adamc@1070 1845 val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
adamc@1070 1846 loc)), loc)
adam@2009 1847 val re = (ERecord ([((CName "Distinct", loc),
adam@2009 1848 dopt),
adam@2009 1849 ((CName "From", loc),
adam@2009 1850 #2 tables),
adam@2009 1851 ((CName "Where", loc),
adam@2009 1852 wopt),
adam@2009 1853 ((CName "GroupBy", loc),
adam@2009 1854 grp),
adam@2009 1855 ((CName "Having", loc),
adam@2009 1856 hopt),
adam@2009 1857 ((CName "SelectFields", loc),
adam@2009 1858 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
adam@2009 1859 sel), loc)),
adam@2009 1860 ((CName "SelectExps", loc),
adam@2009 1861 (ERecord (exps, false), loc))], false), loc)
adamc@223 1862
adamc@209 1863 val e = (EApp (e, re), loc)
adamc@204 1864 in
adamc@207 1865 e
adamc@204 1866 end)
adam@1427 1867 | query1 UNION query1 (sql_relop ("union", false, query11, query12, s (query11left, query12right)))
adam@1427 1868 | query1 INTERSECT query1 (sql_relop ("intersect", false, query11, query12, s (query11left, query12right)))
adam@1427 1869 | query1 EXCEPT query1 (sql_relop ("except", false, query11, query12, s (query11left, query12right)))
adam@1427 1870 | query1 UNION ALL query1 (sql_relop ("union", true, query11, query12, s (query11left, query12right)))
adam@1427 1871 | query1 INTERSECT ALL query1 (sql_relop ("intersect", true, query11, query12, s (query11left, query12right)))
adam@1427 1872 | query1 EXCEPT ALL query1 (sql_relop ("except", true, query11, query12, s (query11left, query12right)))
adamc@1070 1873 | LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp)
adamc@204 1874
adamc@749 1875 tables : fitem (fitem)
adamc@749 1876 | fitem COMMA tables (let
adamc@749 1877 val loc = s (fitemleft, tablesright)
adamc@748 1878
adamc@748 1879 val e = (EVar (["Basis"], "sql_from_comma", Infer), loc)
adamc@749 1880 val e = (EApp (e, #2 fitem), loc)
adamc@748 1881 in
adamc@749 1882 (#1 fitem @ #1 tables,
adamc@748 1883 (EApp (e, #2 tables), loc))
adamc@748 1884 end)
adamc@204 1885
adamc@749 1886 fitem : table' ([#1 table'], #2 table')
adamc@1265 1887 | LBRACE LBRACE eexp RBRACE RBRACE (tnamesOf eexp, eexp)
adamc@749 1888 | fitem JOIN fitem ON sqlexp (let
adamc@749 1889 val loc = s (fitem1left, sqlexpright)
adamc@749 1890
adamc@749 1891 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1892 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1893 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1894 in
adamc@749 1895 (#1 fitem1 @ #1 fitem2,
adamc@749 1896 (EApp (e, sqlexp), loc))
adamc@749 1897 end)
adamc@749 1898 | fitem INNER JOIN fitem ON sqlexp (let
adamc@749 1899 val loc = s (fitem1left, sqlexpright)
adamc@749 1900
adamc@749 1901 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1902 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1903 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1904 in
adamc@749 1905 (#1 fitem1 @ #1 fitem2,
adamc@749 1906 (EApp (e, sqlexp), loc))
adamc@749 1907 end)
adamc@749 1908 | fitem CROSS JOIN fitem (let
adamc@749 1909 val loc = s (fitem1left, fitem2right)
adamc@749 1910
adamc@749 1911 val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
adamc@749 1912 val e = (EApp (e, #2 fitem1), loc)
adamc@749 1913 val e = (EApp (e, #2 fitem2), loc)
adamc@749 1914 val tru = sql_inject (EVar (["Basis"], "True", Infer), loc)
adamc@749 1915 in
adamc@749 1916 (#1 fitem1 @ #1 fitem2,
adamc@749 1917 (EApp (e, tru), loc))
adamc@749 1918 end)
adamc@750 1919 | fitem LEFT JOIN fitem ON sqlexp (let
adamc@750 1920 val loc = s (fitem1left, sqlexpright)
adamc@750 1921
adamc@750 1922 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
adamc@750 1923 val e = (EApp (e, #2 fitem1), loc)
adamc@750 1924 val e = (EApp (e, #2 fitem2), loc)
adamc@750 1925 in
adamc@750 1926 (#1 fitem1 @ #1 fitem2,
adamc@750 1927 (EApp (e, sqlexp), loc))
adamc@750 1928 end)
adamc@751 1929 | fitem LEFT OUTER JOIN fitem ON sqlexp (let
adamc@751 1930 val loc = s (fitem1left, sqlexpright)
adamc@751 1931
adamc@751 1932 val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
adamc@751 1933 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1934 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1935 in
adamc@751 1936 (#1 fitem1 @ #1 fitem2,
adamc@751 1937 (EApp (e, sqlexp), loc))
adamc@751 1938 end)
adamc@751 1939 | fitem RIGHT JOIN fitem ON sqlexp (let
adamc@751 1940 val loc = s (fitem1left, sqlexpright)
adamc@751 1941
adamc@751 1942 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
adamc@751 1943 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1944 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1945 in
adamc@751 1946 (#1 fitem1 @ #1 fitem2,
adamc@751 1947 (EApp (e, sqlexp), loc))
adamc@751 1948 end)
adamc@751 1949 | fitem RIGHT OUTER JOIN fitem ON sqlexp (let
adamc@751 1950 val loc = s (fitem1left, sqlexpright)
adamc@751 1951
adamc@751 1952 val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
adamc@751 1953 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1954 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1955 in
adamc@751 1956 (#1 fitem1 @ #1 fitem2,
adamc@751 1957 (EApp (e, sqlexp), loc))
adamc@751 1958 end)
adamc@751 1959 | fitem FULL JOIN fitem ON sqlexp (let
adamc@751 1960 val loc = s (fitem1left, sqlexpright)
adamc@751 1961
adamc@751 1962 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
adamc@751 1963 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1964 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1965 in
adamc@751 1966 (#1 fitem1 @ #1 fitem2,
adamc@751 1967 (EApp (e, sqlexp), loc))
adamc@751 1968 end)
adamc@751 1969 | fitem FULL OUTER JOIN fitem ON sqlexp (let
adamc@751 1970 val loc = s (fitem1left, sqlexpright)
adamc@751 1971
adamc@751 1972 val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
adamc@751 1973 val e = (EApp (e, #2 fitem1), loc)
adamc@751 1974 val e = (EApp (e, #2 fitem2), loc)
adamc@751 1975 in
adamc@751 1976 (#1 fitem1 @ #1 fitem2,
adamc@751 1977 (EApp (e, sqlexp), loc))
adamc@751 1978 end)
adamc@1192 1979 | LPAREN query RPAREN AS tname (let
adamc@1192 1980 val loc = s (LPARENleft, RPARENright)
adamc@1192 1981
adamc@1192 1982 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
adamc@1192 1983 val e = (ECApp (e, tname), loc)
adamc@1192 1984 in
adamc@1192 1985 ([tname], (EApp (e, query), loc))
adamc@1192 1986 end)
adam@2031 1987 | LPAREN LBRACE LBRACE eexp RBRACE RBRACE RPAREN AS tname (let
adam@2031 1988 val loc = s (LPARENleft, RPARENright)
adam@2031 1989
adam@2031 1990 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
adam@2031 1991 val e = (ECApp (e, tname), loc)
adam@2031 1992 in
adam@2031 1993 ([tname], (EApp (e, eexp), loc))
adam@2031 1994 end)
adam@2006 1995 | LPAREN fitem RPAREN (fitem)
adamc@749 1996
adamc@204 1997 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@204 1998 | LBRACE cexp RBRACE (cexp)
adamc@204 1999
adamc@243 2000 table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
adamc@403 2001 (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@403 2002 | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)))
adamc@221 2003 | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp)
adamc@207 2004
adamc@748 2005 table' : table (let
adamc@748 2006 val loc = s (tableleft, tableright)
adamc@748 2007 val e = (EVar (["Basis"], "sql_from_table", Infer), loc)
adamc@748 2008 val e = (ECApp (e, #1 table), loc)
adamc@748 2009 in
adamc@748 2010 (#1 table, (EApp (e, #2 table), loc))
adamc@748 2011 end)
adamc@748 2012
adamc@243 2013 tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright))
adamc@207 2014 | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@221 2015 | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
adamc@207 2016
adamc@207 2017 fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@207 2018 | LBRACE cexp RBRACE (cexp)
adamc@207 2019
adamc@207 2020 seli : tident DOT fident (Field (tident, fident))
adamc@1194 2021 | sqlexp (Exp (NONE, sqlexp))
adamc@1194 2022 | sqlexp AS fident (Exp (SOME fident, sqlexp))
adamc@341 2023 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))
adam@1627 2024 | tident DOT STAR (StarFields tident)
adamc@207 2025
adamc@207 2026 selis : seli ([seli])
adamc@207 2027 | seli COMMA selis (seli :: selis)
adamc@207 2028
adamc@207 2029 select : STAR (Star)
adamc@207 2030 | selis (Items selis)
adamc@209 2031
adamc@403 2032 sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer),
adamc@209 2033 s (TRUEleft, TRUEright)))
adamc@403 2034 | FALSE (sql_inject (EVar (["Basis"], "False", Infer),
adamc@209 2035 s (FALSEleft, FALSEright)))
adamc@209 2036
adamc@222 2037 | INT (sql_inject (EPrim (Prim.Int INT),
adamc@222 2038 s (INTleft, INTright)))
adamc@222 2039 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
adamc@222 2040 s (FLOATleft, FLOATright)))
adam@2048 2041 | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)),
adamc@229 2042 s (STRINGleft, STRINGright)))
adamc@441 2043 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
adamc@441 2044 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
adamc@222 2045
adamc@221 2046 | tident DOT fident (let
adamc@221 2047 val loc = s (tidentleft, fidentright)
adamc@403 2048 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@221 2049 val e = (ECApp (e, tident), loc)
adamc@221 2050 in
adamc@221 2051 (ECApp (e, fident), loc)
adamc@221 2052 end)
adamc@234 2053 | CSYMBOL (let
adamc@234 2054 val loc = s (CSYMBOLleft, CSYMBOLright)
adamc@310 2055 in
adamc@310 2056 if !inDml then
adamc@310 2057 let
adamc@403 2058 val e = (EVar (["Basis"], "sql_field", Infer), loc)
adamc@310 2059 val e = (ECApp (e, (CName "T", loc)), loc)
adamc@310 2060 in
adamc@310 2061 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 2062 end
adamc@310 2063 else
adamc@310 2064 let
adamc@403 2065 val e = (EVar (["Basis"], "sql_exp", Infer), loc)
adamc@310 2066 in
adamc@310 2067 (ECApp (e, (CName CSYMBOL, loc)), loc)
adamc@310 2068 end
adamc@310 2069 end)
adamc@221 2070
adamc@471 2071 | LBRACE eexp RBRACE (eexp)
adamc@470 2072
adamc@559 2073 | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2074 | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2075 | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2076 | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2077 | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2078 | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2079
adamc@559 2080 | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2081 | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2082 | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2083 | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2084 | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@219 2085
adamc@220 2086 | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@220 2087 | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
adamc@559 2088
kkallio@1607 2089 | sqlexp LIKE sqlexp (sql_binary ("like", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
kkallio@1607 2090
adamc@220 2091 | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
adamc@559 2092 | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright)))
adamc@220 2093
adamc@470 2094 | sqlexp IS NULL (let
adamc@470 2095 val loc = s (sqlexpleft, NULLright)
adamc@470 2096 in
adamc@470 2097 (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc),
adamc@470 2098 sqlexp), loc)
adamc@470 2099 end)
adamc@470 2100
kkallio@1572 2101 | CIF sqlexp CTHEN sqlexp CELSE sqlexp (let
kkallio@1572 2102 val loc = s (CIFleft, sqlexp3right)
kkallio@1572 2103 val e = (EVar (["Basis"], "sql_if_then_else", Infer), loc)
kkallio@1572 2104 in
kkallio@1572 2105 (EApp ((EApp ((EApp (e, sqlexp1), loc), sqlexp2), loc), sqlexp3), loc)
kkallio@1572 2106 end)
kkallio@1572 2107
adamc@471 2108 | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp,
adamc@471 2109 s (LBRACEleft, RBRACEright)))
adamc@220 2110 | LPAREN sqlexp RPAREN (sqlexp)
adamc@210 2111
adamc@467 2112 | NULL (sql_inject ((EVar (["Basis"], "None", Infer),
adamc@467 2113 s (NULLleft, NULLright))))
adamc@467 2114
adam@1778 2115 | COUNT LPAREN STAR RPAREN window(let
adam@1778 2116 val loc = s (COUNTleft, windowright)
adam@1778 2117 in
adam@1778 2118 case window of
adam@1778 2119 NONE => (EVar (["Basis"], "sql_count", Infer), loc)
adam@1778 2120 | SOME _ => applyWindow loc (EVar (["Basis"], "sql_window_count", Infer), loc) window
adam@1778 2121 end)
adam@1778 2122 | COUNT LPAREN sqlexp RPAREN window(let
adam@1778 2123 val loc = s (COUNTleft, RPARENright)
adam@1778 2124 val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
adam@1778 2125 in
adam@1778 2126 case window of
adam@1778 2127 NONE =>
adam@1778 2128 let
adam@1778 2129 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
adam@1778 2130 e), loc)
adam@1778 2131 in
adam@1778 2132 (EApp (e, sqlexp), loc)
adam@1778 2133 end
adam@1778 2134 | SOME _ =>
adam@1778 2135 let
adam@1778 2136 val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
adam@1778 2137 val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
adam@1778 2138 e), loc)
adam@1778 2139 in
adam@1778 2140 applyWindow loc (EApp (e, sqlexp), loc) window
adam@1778 2141 end
adam@1778 2142 end)
adam@1776 2143 | sqlagg LPAREN sqlexp RPAREN window (let
adam@1778 2144 val loc = s (sqlaggleft, RPARENright)
adam@1778 2145
adam@1776 2146 val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
adam@1776 2147 in
adam@1776 2148 case window of
adam@1776 2149 NONE =>
adam@1776 2150 let
adam@1776 2151 val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
adam@1776 2152 e), loc)
adam@1776 2153 in
adam@1776 2154 (EApp (e, sqlexp), loc)
adam@1776 2155 end
adam@1776 2156 | SOME _ =>
adam@1776 2157 let
adam@1776 2158 val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
adam@1776 2159 e), loc)
adam@1776 2160 in
adam@1778 2161 applyWindow loc (EApp (e, sqlexp), loc) window
adam@1776 2162 end
adam@1776 2163 end)
adam@1778 2164 | RANK UNIT window (let
adam@1778 2165 val loc = s (RANKleft, windowright)
adam@1778 2166 in
adam@1778 2167 applyWindow loc (EVar (["Basis"], "sql_rank", Infer), loc) window
adam@1778 2168 end)
adam@1602 2169 | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
adam@1602 2170 (let
adam@1602 2171 val loc = s (COALESCEright, sqlexp2right)
adam@1602 2172 val e = (EVar (["Basis"], "sql_coalesce", Infer), loc)
adam@1602 2173 val e = (EApp (e, sqlexp1), loc)
adam@1602 2174 in
adam@1602 2175 (EApp (e, sqlexp2), loc)
adam@1602 2176 end)
adamc@746 2177 | fname LPAREN sqlexp RPAREN (let
adamc@746 2178 val loc = s (fnameleft, RPARENright)
adamc@746 2179
adamc@746 2180 val e = (EVar (["Basis"], "sql_ufunc", Infer), loc)
adamc@746 2181 val e = (EApp (e, fname), loc)
adamc@746 2182 in
adamc@746 2183 (EApp (e, sqlexp), loc)
adamc@746 2184 end)
adamc@1191 2185 | LPAREN query RPAREN (let
adamc@1191 2186 val loc = s (LPARENleft, RPARENright)
adamc@1191 2187
adamc@1191 2188 val e = (EVar (["Basis"], "sql_subquery", Infer), loc)
adamc@1191 2189 in
adamc@1191 2190 (EApp (e, query), loc)
adamc@1191 2191 end)
adamc@746 2192
adam@1776 2193 window : (NONE)
adam@1777 2194 | OVER LPAREN pbopt obopt RPAREN (SOME (pbopt, obopt))
adam@1777 2195
adam@1777 2196 pbopt : ((EVar (["Basis"], "sql_no_partition", Infer), dummy))
adam@1777 2197 | PARTITION BY sqlexp (let
adam@1777 2198 val loc = s (PARTITIONleft, sqlexpright)
adam@1777 2199
adam@1777 2200 val e = (EVar (["Basis"], "sql_partition", Infer), loc)
adam@1777 2201 in
adam@1777 2202 (EApp (e, sqlexp), loc)
adam@1777 2203 end)
adam@1776 2204
adamc@746 2205 fname : SYMBOL (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
adamc@746 2206 | LBRACE eexp RBRACE (eexp)
adamc@235 2207
adamc@403 2208 wopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 2209 dummy))
adamc@209 2210 | CWHERE sqlexp (sqlexp)
adamc@226 2211
adamc@226 2212 groupi : tident DOT fident (GField (tident, fident))
adam@1425 2213 | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (GFields (tident, cexp))
adamc@226 2214
adamc@226 2215 groupis: groupi ([groupi])
adamc@226 2216 | groupi COMMA groupis (groupi :: groupis)
adamc@226 2217
adamc@226 2218 gopt : (NONE)
adamc@226 2219 | GROUP BY groupis (SOME groupis)
adamc@227 2220
adamc@403 2221 hopt : (sql_inject (EVar (["Basis"], "True", Infer),
adamc@230 2222 dummy))
adamc@227 2223 | HAVING sqlexp (sqlexp)
adamc@230 2224
adamc@403 2225 obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
adamc@234 2226 (CWild (KRecord (KType, dummy), dummy), dummy)),
adamc@230 2227 dummy)
adamc@230 2228 | ORDER BY obexps (obexps)
adamc@230 2229
adamc@268 2230 obitem : sqlexp diropt (sqlexp, diropt)
adamc@268 2231
adamc@268 2232 obexps : obitem (let
adamc@268 2233 val loc = s (obitemleft, obitemright)
adamc@230 2234
adamc@403 2235 val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc),
adamc@234 2236 (CWild (KRecord (KType, loc), loc), loc)),
adamc@230 2237 loc)
adamc@403 2238 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 2239 #1 obitem), loc)
adamc@268 2240 val e = (EApp (e, #2 obitem), loc)
adamc@230 2241 in
adamc@230 2242 (EApp (e, e'), loc)
adamc@230 2243 end)
adamc@268 2244 | obitem COMMA obexps (let
adamc@268 2245 val loc = s (obitemleft, obexpsright)
adamc@230 2246
adamc@403 2247 val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc),
adamc@268 2248 #1 obitem), loc)
adamc@268 2249 val e = (EApp (e, #2 obitem), loc)
adamc@230 2250 in
adamc@230 2251 (EApp (e, obexps), loc)
adamc@230 2252 end)
adam@1682 2253 | RANDOM popt (EVar (["Basis"], "sql_order_by_random", Infer), s (RANDOMleft, poptright))
adam@1682 2254
adam@1682 2255 popt : ()
adam@1682 2256 | LPAREN RPAREN ()
adam@1684 2257 | UNIT ()
adamc@231 2258
adamc@403 2259 diropt : (EVar (["Basis"], "sql_asc", Infer), dummy)
adamc@403 2260 | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
adamc@403 2261 | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright))
adam@1543 2262 | LBRACE eexp RBRACE (eexp)
adamc@268 2263
adamc@403 2264 lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@403 2265 | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy)
adamc@231 2266 | LIMIT sqlint (let
adamc@231 2267 val loc = s (LIMITleft, sqlintright)
adamc@231 2268 in
adamc@403 2269 (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc)
adamc@231 2270 end)
adamc@231 2271
adamc@403 2272 ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy)
adamc@232 2273 | OFFSET sqlint (let
adamc@232 2274 val loc = s (OFFSETleft, sqlintright)
adamc@232 2275 in
adamc@403 2276 (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc)
adamc@232 2277 end)
adamc@232 2278
adamc@231 2279 sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@231 2280 | LBRACE eexp RBRACE (eexp)
adamc@236 2281
adamc@236 2282 sqlagg : AVG ("avg")
adamc@236 2283 | SUM ("sum")
adamc@236 2284 | MIN ("min")
adamc@236 2285 | MAX ("max")
adam@2010 2286
adam@2010 2287 ffi_mode : SYMBOL (case SYMBOL of
adam@2010 2288 "effectful" => Effectful
adam@2010 2289 | "benignEffectful" => BenignEffectful
adam@2010 2290 | "clientOnly" => ClientOnly
adam@2010 2291 | "serverOnly" => ServerOnly
adam@2010 2292 | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
adam@2010 2293 | SYMBOL STRING (case SYMBOL of
adam@2010 2294 "jsFunc" => JsFunc STRING
adam@2010 2295 | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
adam@2010 2296
adam@2010 2297 ffi_modes : ([])
adam@2010 2298 | ffi_mode ffi_modes (ffi_mode :: ffi_modes)