Mercurial > urweb

comparison src/urweb.grm @ 1645:b71cc5ec59b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge
author Adam Chlipala <adam@chlipala.net>
date Wed, 28 Dec 2011 10:30:56 -0500
parents b0720700c36e
children ca3b73a7b4d0
comparison
equal deleted inserted replaced
1644:75cf4a68f6c9 1645:b71cc5ec59b3
1 (* Copyright (c) 2008-2010, Adam Chlipala 1 (* Copyright (c) 2008-2011, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
217 "table" => "tabl" 217 "table" => "tabl"
218 | _ => bt 218 | _ => bt
219 219
220 datatype prop_kind = Delete | Update 220 datatype prop_kind = Delete | Update
221 221
222 datatype attr = Class of exp | Normal of con * exp 222 datatype attr = Class of exp | DynClass of exp | Normal of con * exp
223 223
224 fun patType loc (p : pat) = 224 fun patType loc (p : pat) =
225 case #1 p of 225 case #1 p of
226 PAnnot (_, t) => t 226 PAnnot (_, t) => t
227 | _ => (CWild (KType, loc), loc) 227 | _ => (CWild (KType, loc), loc)
353 | etuple of exp list 353 | etuple of exp list
354 | rexp of (con * exp) list 354 | rexp of (con * exp) list
355 | xml of exp 355 | xml of exp
356 | xmlOne of exp 356 | xmlOne of exp
357 | xmlOpt of exp 357 | xmlOpt of exp
358 | tag of (string * exp) * exp option * exp 358 | tag of (string * exp) * exp option * exp option * exp
359 | tagHead of string * exp 359 | tagHead of string * exp
360 | bind of string * con option * exp 360 | bind of string * con option * exp
361 | edecl of edecl 361 | edecl of edecl
362 | edecls of edecl list 362 | edecls of edecl list
363 363
374 | patS of pat 374 | patS of pat
375 | pterm of pat 375 | pterm of pat
376 | rpat of (string * pat) list * bool 376 | rpat of (string * pat) list * bool
377 | ptuple of pat list 377 | ptuple of pat list
378 378
379 | attrs of exp option * (con * exp) list 379 | attrs of exp option * exp option * (con * exp) list
380 | attr of attr 380 | attr of attr
381 | attrv of exp 381 | attrv of exp
382 382
383 | query of exp 383 | query of exp
384 | query1 of exp 384 | query1 of exp
1440 1440
1441 val cdata = (EApp (cdata, 1441 val cdata = (EApp (cdata,
1442 (EPrim (Prim.String ""), pos)), 1442 (EPrim (Prim.String ""), pos)),
1443 pos) 1443 pos)
1444 in 1444 in
1445 (EApp (#3 tag, cdata), pos) 1445 (EApp (#4 tag, cdata), pos)
1446 end) 1446 end)
1447 1447
1448 | tag GT xmlOpt END_TAG (let 1448 | tag GT xmlOpt END_TAG (let
1449 fun tagOut s = 1449 fun tagOut s =
1450 case s of 1450 case s of
1457 if #1 (#1 tag) = et then 1457 if #1 (#1 tag) = et then
1458 if et = "form" then 1458 if et = "form" then
1459 let 1459 let
1460 val e = (EVar (["Basis"], "form", Infer), pos) 1460 val e = (EVar (["Basis"], "form", Infer), pos)
1461 val e = (EApp (e, case #2 tag of 1461 val e = (EApp (e, case #2 tag of
1462 NONE => (EVar (["Basis"], "None", Infer), pos)
1463 | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
1464 val e = (EApp (e, case #3 tag of
1462 NONE => (EVar (["Basis"], "None", Infer), pos) 1465 NONE => (EVar (["Basis"], "None", Infer), pos)
1463 | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) 1466 | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
1464 in 1467 in
1465 (EApp (e, xmlOpt), pos) 1468 (EApp (e, xmlOpt), pos)
1466 end 1469 end
1469 xmlOpt), pos) 1472 xmlOpt), pos)
1470 else if et = "entry" then 1473 else if et = "entry" then
1471 (EApp ((EVar (["Basis"], "entry", Infer), pos), 1474 (EApp ((EVar (["Basis"], "entry", Infer), pos),
1472 xmlOpt), pos) 1475 xmlOpt), pos)
1473 else 1476 else
1474 (EApp (#3 tag, xmlOpt), pos) 1477 (EApp (#4 tag, xmlOpt), pos)
1475 else 1478 else
1476 (if ErrorMsg.anyErrors () then 1479 (if ErrorMsg.anyErrors () then
1477 () 1480 ()
1478 else 1481 else
1479 ErrorMsg.errorAt pos ("Begin tag <" 1482 ErrorMsg.errorAt pos ("Begin tag <"
1498 val eo = case #1 attrs of 1501 val eo = case #1 attrs of
1499 NONE => (EVar (["Basis"], "None", Infer), pos) 1502 NONE => (EVar (["Basis"], "None", Infer), pos)
1500 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), 1503 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1501 e), pos) 1504 e), pos)
1502 val e = (EApp (e, eo), pos) 1505 val e = (EApp (e, eo), pos)
1503 val e = (EApp (e, (ERecord (#2 attrs), pos)), pos) 1506 val eo = case #2 attrs of
1507 NONE => (EVar (["Basis"], "None", Infer), pos)
1508 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1509 e), pos)
1510 val e = (EApp (e, eo), pos)
1511 val e = (EApp (e, (ERecord (#3 attrs), pos)), pos)
1504 val e = (EApp (e, (EApp (#2 tagHead, 1512 val e = (EApp (e, (EApp (#2 tagHead,
1505 (ERecord [], pos)), pos)), pos) 1513 (ERecord [], pos)), pos)), pos)
1506 in 1514 in
1507 (tagHead, #1 attrs, e) 1515 (tagHead, #1 attrs, #2 attrs, e)
1508 end) 1516 end)
1509 1517
1510 tagHead: BEGIN_TAG (let 1518 tagHead: BEGIN_TAG (let
1511 val bt = tagIn BEGIN_TAG 1519 val bt = tagIn BEGIN_TAG
1512 val pos = s (BEGIN_TAGleft, BEGIN_TAGright) 1520 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
1514 (bt, 1522 (bt,
1515 (EVar (["Basis"], bt, Infer), pos)) 1523 (EVar (["Basis"], bt, Infer), pos))
1516 end) 1524 end)
1517 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) 1525 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
1518 1526
1519 attrs : (NONE, []) 1527 attrs : (NONE, NONE, [])
1520 | attr attrs (let 1528 | attr attrs (let
1521 val loc = s (attrleft, attrsright) 1529 val loc = s (attrleft, attrsright)
1522 in 1530 in
1523 case attr of 1531 case attr of
1524 Class e => 1532 Class e =>
1525 (case #1 attrs of 1533 (case #1 attrs of
1526 NONE => () 1534 NONE => ()
1527 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; 1535 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
1528 (SOME e, #2 attrs)) 1536 (SOME e, #2 attrs, #3 attrs))
1537 | DynClass e =>
1538 (case #2 attrs of
1539 NONE => ()
1540 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
1541 (#1 attrs, SOME e, #3 attrs))
1529 | Normal xe => 1542 | Normal xe =>
1530 (#1 attrs, xe :: #2 attrs) 1543 (#1 attrs, #2 attrs, xe :: #3 attrs)
1531 end) 1544 end)
1532 1545
1533 attr : SYMBOL EQ attrv (if SYMBOL = "class" then 1546 attr : SYMBOL EQ attrv (case SYMBOL of
1534 Class attrv 1547 "class" => Class attrv
1535 else 1548 | "dynClass" => DynClass attrv
1549 | _ =>
1536 let 1550 let
1537 val sym = 1551 val sym =
1538 case SYMBOL of 1552 case SYMBOL of
1539 "type" => "Typ" 1553 "type" => "Typ"
1540 | x => capitalize x 1554 | x => capitalize x