Mercurial > urweb

comparison src/cjr_print.sml @ 398:ab3177746c78

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Simple listShop working
author Adam Chlipala <adamc@hcoop.net>
date Tue, 21 Oct 2008 13:24:54 -0400
parents 519366a76603
children ebf27030ae3b
comparison
equal deleted inserted replaced
397:4d519baf357c 398:ab3177746c78
1461 "" 1461 ""
1462 else 1462 else
1463 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 1463 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
1464 1464
1465 fun unurlify (t, loc) = 1465 fun unurlify (t, loc) =
1466 case t of 1466 let
1467 TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") 1467 fun unurlify' rf t =
1468 1468 case t of
1469 | TRecord 0 => string "uw_unit_v" 1469 TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
1470 | TRecord i => 1470
1471 let 1471 | TRecord 0 => string "uw_unit_v"
1472 val xts = E.lookupStruct env i 1472 | TRecord i =>
1473 in 1473 let
1474 box [string "({", 1474 val xts = E.lookupStruct env i
1475 newline, 1475 in
1476 box (map (fn (x, t) => 1476 box [string "({",
1477 box [p_typ env t,
1478 space,
1479 string x,
1480 space,
1481 string "=",
1482 space,
1483 unurlify t,
1484 string ";",
1485 newline]) xts),
1486 string "struct",
1487 space,
1488 string "__uws_",
1489 string (Int.toString i),
1490 space,
1491 string "tmp",
1492 space,
1493 string "=",
1494 space,
1495 string "{",
1496 space,
1497 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
1498 space,
1499 string "};",
1500 newline,
1501 string "tmp;",
1502 newline,
1503 string "})"]
1504 end
1505
1506 | TDatatype (Enum, i, _) =>
1507 let
1508 val (x, xncs) = E.lookupDatatype env i
1509
1510 fun doEm xncs =
1511 case xncs of
1512 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
1513 ^ x ^ "_" ^ Int.toString i ^ ")0)")
1514 | (x', n, to) :: rest =>
1515 box [string "((!strncmp(request, \"",
1516 string x',
1517 string "\", ",
1518 string (Int.toString (size x')),
1519 string ") && (request[",
1520 string (Int.toString (size x')),
1521 string "] == 0 || request[",
1522 string (Int.toString (size x')),
1523 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
1524 space,
1525 string ":",
1526 space,
1527 doEm rest,
1528 string ")"]
1529 in
1530 doEm xncs
1531 end
1532
1533 | TDatatype (Option, i, xncs) =>
1534 let
1535 val (x, _) = E.lookupDatatype env i
1536
1537 val (no_arg, has_arg, t) =
1538 case !xncs of
1539 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
1540 (no_arg, has_arg, t)
1541 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
1542 (no_arg, has_arg, t)
1543 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
1544 in
1545 box [string "(request[0] == '/' ? ++request : request,",
1546 newline,
1547 string "((!strncmp(request, \"",
1548 string no_arg,
1549 string "\", ",
1550 string (Int.toString (size no_arg)),
1551 string ") && (request[",
1552 string (Int.toString (size no_arg)),
1553 string "] == 0 || request[",
1554 string (Int.toString (size no_arg)),
1555 string "] == '/')) ? (request",
1556 space,
1557 string "+=",
1558 space,
1559 string (Int.toString (size no_arg)),
1560 string ", NULL) : ((!strncmp(request, \"",
1561 string has_arg,
1562 string "\", ",
1563 string (Int.toString (size has_arg)),
1564 string ") && (request[",
1565 string (Int.toString (size has_arg)),
1566 string "] == 0 || request[",
1567 string (Int.toString (size has_arg)),
1568 string "] == '/')) ? (request",
1569 space,
1570 string "+=",
1571 space,
1572 string (Int.toString (size has_arg)),
1573 string ", (request[0] == '/' ? ++request : NULL), ",
1574 newline,
1575
1576 case #1 t of
1577 TDatatype _ => unurlify t
1578 | TFfi ("Basis", "string") => unurlify t
1579 | _ => box [string "({",
1580 newline,
1581 p_typ env t,
1582 space,
1583 string "*tmp",
1584 space,
1585 string "=",
1586 space,
1587 string "uw_malloc(ctx, sizeof(",
1588 p_typ env t,
1589 string "));",
1590 newline,
1591 string "*tmp",
1592 space,
1593 string "=",
1594 space,
1595 unurlify t,
1596 string ";",
1597 newline,
1598 string "tmp;",
1599 newline,
1600 string "})"],
1601 string ")",
1602 newline,
1603 string ":",
1604 space,
1605 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
1606 end
1607
1608 | TDatatype (Default, i, _) =>
1609 let
1610 val (x, xncs) = E.lookupDatatype env i
1611
1612 fun doEm xncs =
1613 case xncs of
1614 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
1615 | (x', n, to) :: rest =>
1616 box [string "((!strncmp(request, \"",
1617 string x',
1618 string "\", ",
1619 string (Int.toString (size x')),
1620 string ") && (request[",
1621 string (Int.toString (size x')),
1622 string "] == 0 || request[",
1623 string (Int.toString (size x')),
1624 string "] == '/')) ? ({",
1625 newline, 1477 newline,
1478 box (map (fn (x, t) =>
1479 box [p_typ env t,
1480 space,
1481 string "uwr_",
1482 string x,
1483 space,
1484 string "=",
1485 space,
1486 unurlify' rf (#1 t),
1487 string ";",
1488 newline]) xts),
1626 string "struct", 1489 string "struct",
1627 space, 1490 space,
1628 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), 1491 string "__uws_",
1492 string (Int.toString i),
1629 space, 1493 space,
1630 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", 1494 string "tmp",
1631 string x,
1632 string "_",
1633 string (Int.toString i),
1634 string "));",
1635 newline,
1636 string "tmp->tag",
1637 space, 1495 space,
1638 string "=", 1496 string "=",
1639 space, 1497 space,
1640 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), 1498 string "{",
1641 string ";", 1499 space,
1500 p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
1501 string x]) xts,
1502 space,
1503 string "};",
1642 newline, 1504 newline,
1643 string "request",
1644 space,
1645 string "+=",
1646 space,
1647 string (Int.toString (size x')),
1648 string ";",
1649 newline,
1650 string "if (request[0] == '/') ++request;",
1651 newline,
1652 case to of
1653 NONE => box []
1654 | SOME t => box [string "tmp->data.uw_",
1655 p_ident x',
1656 space,
1657 string "=",
1658 space,
1659 unurlify t,
1660 string ";",
1661 newline],
1662 string "tmp;", 1505 string "tmp;",
1663 newline, 1506 newline,
1664 string "})", 1507 string "})"]
1665 space, 1508 end
1666 string ":", 1509
1667 space, 1510 | TDatatype (Enum, i, _) =>
1668 doEm rest, 1511 let
1669 string ")"] 1512 val (x, xncs) = E.lookupDatatype env i
1670 in 1513
1671 doEm xncs 1514 fun doEm xncs =
1672 end 1515 case xncs of
1673 1516 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
1674 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; 1517 ^ x ^ "_" ^ Int.toString i ^ ")0)")
1675 space) 1518 | (x', n, to) :: rest =>
1676 1519 box [string "((!strncmp(request, \"",
1520 string x',
1521 string "\", ",
1522 string (Int.toString (size x')),
1523 string ") && (request[",
1524 string (Int.toString (size x')),
1525 string "] == 0 || request[",
1526 string (Int.toString (size x')),
1527 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
1528 space,
1529 string ":",
1530 space,
1531 doEm rest,
1532 string ")"]
1533 in
1534 doEm xncs
1535 end
1536
1537 | TDatatype (Option, i, xncs) =>
1538 if IS.member (rf, i) then
1539 box [string "unurlify_",
1540 string (Int.toString i),
1541 string "()"]
1542 else
1543 let
1544 val (x, _) = E.lookupDatatype env i
1545
1546 val (no_arg, has_arg, t) =
1547 case !xncs of
1548 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
1549 (no_arg, has_arg, t)
1550 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
1551 (no_arg, has_arg, t)
1552 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
1553
1554 val rf = IS.add (rf, i)
1555 in
1556 box [string "({",
1557 space,
1558 p_typ env t,
1559 space,
1560 string "*unurlify_",
1561 string (Int.toString i),
1562 string "(void) {",
1563 newline,
1564 box [string "return (request[0] == '/' ? ++request : request,",
1565 newline,
1566 string "((!strncmp(request, \"",
1567 string no_arg,
1568 string "\", ",
1569 string (Int.toString (size no_arg)),
1570 string ") && (request[",
1571 string (Int.toString (size no_arg)),
1572 string "] == 0 || request[",
1573 string (Int.toString (size no_arg)),
1574 string "] == '/')) ? (request",
1575 space,
1576 string "+=",
1577 space,
1578 string (Int.toString (size no_arg)),
1579 string ", NULL) : ((!strncmp(request, \"",
1580 string has_arg,
1581 string "\", ",
1582 string (Int.toString (size has_arg)),
1583 string ") && (request[",
1584 string (Int.toString (size has_arg)),
1585 string "] == 0 || request[",
1586 string (Int.toString (size has_arg)),
1587 string "] == '/')) ? (request",
1588 space,
1589 string "+=",
1590 space,
1591 string (Int.toString (size has_arg)),
1592 string ", (request[0] == '/' ? ++request : NULL), ",
1593 newline,
1594
1595 case #1 t of
1596 TDatatype _ => unurlify' rf (#1 t)
1597 | TFfi ("Basis", "string") => unurlify' rf (#1 t)
1598 | _ => box [string "({",
1599 newline,
1600 p_typ env t,
1601 space,
1602 string "*tmp",
1603 space,
1604 string "=",
1605 space,
1606 string "uw_malloc(ctx, sizeof(",
1607 p_typ env t,
1608 string "));",
1609 newline,
1610 string "*tmp",
1611 space,
1612 string "=",
1613 space,
1614 unurlify' rf (#1 t),
1615 string ";",
1616 newline,
1617 string "tmp;",
1618 newline,
1619 string "})"],
1620 string ")",
1621 newline,
1622 string ":",
1623 space,
1624 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
1625 ^ "\"), NULL))));"),
1626 newline],
1627 string "}",
1628 newline,
1629 newline,
1630
1631 string "unurlify_",
1632 string (Int.toString i),
1633 string "();",
1634 newline,
1635 string "})"]
1636 end
1637
1638 | TDatatype (Default, i, _) =>
1639 let
1640 val (x, xncs) = E.lookupDatatype env i
1641
1642 fun doEm xncs =
1643 case xncs of
1644 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
1645 | (x', n, to) :: rest =>
1646 box [string "((!strncmp(request, \"",
1647 string x',
1648 string "\", ",
1649 string (Int.toString (size x')),
1650 string ") && (request[",
1651 string (Int.toString (size x')),
1652 string "] == 0 || request[",
1653 string (Int.toString (size x')),
1654 string "] == '/')) ? ({",
1655 newline,
1656 string "struct",
1657 space,
1658 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
1659 space,
1660 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
1661 string x,
1662 string "_",
1663 string (Int.toString i),
1664 string "));",
1665 newline,
1666 string "tmp->tag",
1667 space,
1668 string "=",
1669 space,
1670 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
1671 string ";",
1672 newline,
1673 string "request",
1674 space,
1675 string "+=",
1676 space,
1677 string (Int.toString (size x')),
1678 string ";",
1679 newline,
1680 string "if (request[0] == '/') ++request;",
1681 newline,
1682 case to of
1683 NONE => box []
1684 | SOME (t, _) => box [string "tmp->data.uw_",
1685 p_ident x',
1686 space,
1687 string "=",
1688 space,
1689 unurlify' rf t,
1690 string ";",
1691 newline],
1692 string "tmp;",
1693 newline,
1694 string "})",
1695 space,
1696 string ":",
1697 space,
1698 doEm rest,
1699 string ")"]
1700 in
1701 doEm xncs
1702 end
1703
1704 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
1705 space)
1706 in
1707 unurlify' IS.empty t
1708 end
1677 1709
1678 fun p_page (ek, s, n, ts) = 1710 fun p_page (ek, s, n, ts) =
1679 let 1711 let
1680 val (ts, defInputs, inputsVar) = 1712 val (ts, defInputs, inputsVar) =
1681 case ek of 1713 case ek of