Mercurial > urweb

comparison src/cjr_print.sml @ 1516:c4f39b49aa2d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
A few more tweaks to support Clang (including ending use of nested functions)
author Adam Chlipala <adam@chlipala.net>
date Sat, 23 Jul 2011 16:27:04 -0400
parents dcc8abbc6dfd
children a71223513c77
comparison
equal deleted inserted replaced
1515:8c65218920cf 1516:c4f39b49aa2d
521 if s = "" then 521 if s = "" then
522 "" 522 ""
523 else 523 else
524 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 524 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
525 525
526 local
527 val urlHandlers = ref ([] : pp_desc list)
528 in
529
530 fun addUrlHandler v = urlHandlers := v :: !urlHandlers
531
532 fun latestUrlHandlers () =
533 !urlHandlers
534 before urlHandlers := []
535
536 fun clearUrlHandlers () = urlHandlers := []
537
538 end
539
540 val unurlifies = ref IS.empty
541
526 fun unurlify fromClient env (t, loc) = 542 fun unurlify fromClient env (t, loc) =
527 let 543 let
528 fun unurlify' rf t = 544 fun unurlify' request t =
529 case t of 545 case t of
530 TFfi ("Basis", "unit") => string "uw_Basis_unurlifyUnit(ctx, &request)" 546 TFfi ("Basis", "unit") => string ("uw_Basis_unurlifyUnit(ctx, &" ^ request ^ ")")
531 | TFfi ("Basis", "string") => string (if fromClient then 547 | TFfi ("Basis", "string") => string (if fromClient then
532 "uw_Basis_unurlifyString_fromClient(ctx, &request)" 548 "uw_Basis_unurlifyString_fromClient(ctx, &" ^ request ^ ")"
533 else 549 else
534 "uw_Basis_unurlifyString(ctx, &request)") 550 "uw_Basis_unurlifyString(ctx, &" ^ request ^ ")")
535 | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") 551 | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &" ^ request ^ ")")
536 552
537 | TRecord 0 => string "uw_Basis_unurlifyUnit(ctx, &request)" 553 | TRecord 0 => string ("uw_Basis_unurlifyUnit(ctx, &" ^ request ^ ")")
538 | TRecord i => 554 | TRecord i =>
539 let 555 let
540 val xts = E.lookupStruct env i 556 val xts = E.lookupStruct env i
541 in 557 in
542 box [string "({", 558 box [string "({",
547 string "uwr_", 563 string "uwr_",
548 string x, 564 string x,
549 space, 565 space,
550 string "=", 566 string "=",
551 space, 567 space,
552 unurlify' rf (#1 t), 568 unurlify' request (#1 t),
553 string ";", 569 string ";",
554 newline]) xts), 570 newline]) xts),
555 string "struct", 571 string "struct",
556 space, 572 space,
557 string "__uws_", 573 string "__uws_",
581 case xncs of 597 case xncs of
582 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " 598 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
583 ^ x ^ "\"), (enum __uwe_" 599 ^ x ^ "\"), (enum __uwe_"
584 ^ x ^ "_" ^ Int.toString i ^ ")0)") 600 ^ x ^ "_" ^ Int.toString i ^ ")0)")
585 | (x', n, to) :: rest => 601 | (x', n, to) :: rest =>
586 box [string "((!strncmp(request, \"", 602 box [string ("((!strncmp(" ^ request ^ ", \""),
587 string x', 603 string x',
588 string "\", ", 604 string "\", ",
589 string (Int.toString (size x')), 605 string (Int.toString (size x')),
590 string ") && (request[", 606 string (") && (" ^ request ^ "["),
591 string (Int.toString (size x')), 607 string (Int.toString (size x')),
592 string "] == 0 || request[", 608 string ("] == 0 || " ^ request ^ "["),
593 string (Int.toString (size x')), 609 string (Int.toString (size x')),
594 string "] == '/')) ? (request += ", 610 string ("] == '/')) ? (" ^ request ^ " += "),
595 string (Int.toString (size x')), 611 string (Int.toString (size x')),
596 string (", (*request == '/' ? ++request : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"), 612 string (", (" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"),
597 space, 613 space,
598 string ":", 614 string ":",
599 space, 615 space,
600 doEm rest, 616 doEm rest,
601 string ")"] 617 string ")"]
602 in 618 in
603 doEm xncs 619 doEm xncs
604 end 620 end
605 621
606 | TDatatype (Option, i, xncs) => 622 | TDatatype (Option, i, xncs) =>
607 if IS.member (rf, i) then 623 if IS.member (!unurlifies, i) then
608 box [string "unurlify_", 624 box [string "unurlify_",
609 string (Int.toString i), 625 string (Int.toString i),
610 string "()"] 626 string ("(ctx, &" ^ request ^ ")")]
611 else 627 else
612 let 628 let
613 val (x, _) = E.lookupDatatype env i 629 val (x, _) = E.lookupDatatype env i
614 630
615 val (no_arg, has_arg, t) = 631 val (no_arg, has_arg, t) =
617 [(no_arg, _, NONE), (has_arg, _, SOME t)] => 633 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
618 (no_arg, has_arg, t) 634 (no_arg, has_arg, t)
619 | [(has_arg, _, SOME t), (no_arg, _, NONE)] => 635 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
620 (no_arg, has_arg, t) 636 (no_arg, has_arg, t)
621 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" 637 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
622
623 val rf = IS.add (rf, i)
624 in 638 in
625 box [string "({", 639 unurlifies := IS.add (!unurlifies, i);
626 space, 640 addUrlHandler (box [string "static",
627 p_typ env t, 641 space,
628 space, 642 p_typ env t,
629 string "*unurlify_", 643 space,
630 string (Int.toString i), 644 string "*unurlify_",
631 string "(void) {", 645 string (Int.toString i),
632 newline, 646 string "(uw_context ctx, char **request) {",
633 box [string "return (request[0] == '/' ? ++request : request,", 647 newline,
634 newline, 648 box [string "return ((*request)[0] == '/' ? ++*request : *request,",
635 string "((!strncmp(request, \"", 649 newline,
636 string no_arg, 650 string "((!strncmp(*request, \"",
637 string "\", ", 651 string no_arg,
638 string (Int.toString (size no_arg)), 652 string "\", ",
639 string ") && (request[", 653 string (Int.toString (size no_arg)),
640 string (Int.toString (size no_arg)), 654 string ") && ((*request)[",
641 string "] == 0 || request[", 655 string (Int.toString (size no_arg)),
642 string (Int.toString (size no_arg)), 656 string "] == 0 || (*request)[",
643 string "] == '/')) ? (request", 657 string (Int.toString (size no_arg)),
644 space, 658 string "] == '/')) ? (*request",
645 string "+=", 659 space,
646 space, 660 string "+=",
647 string (Int.toString (size no_arg)), 661 space,
648 string ", NULL) : ((!strncmp(request, \"", 662 string (Int.toString (size no_arg)),
649 string has_arg, 663 string ", NULL) : ((!strncmp(*request, \"",
650 string "\", ", 664 string has_arg,
651 string (Int.toString (size has_arg)), 665 string "\", ",
652 string ") && (request[", 666 string (Int.toString (size has_arg)),
653 string (Int.toString (size has_arg)), 667 string ") && ((*request)[",
654 string "] == 0 || request[", 668 string (Int.toString (size has_arg)),
655 string (Int.toString (size has_arg)), 669 string "] == 0 || (*request)[",
656 string "] == '/')) ? (request", 670 string (Int.toString (size has_arg)),
657 space, 671 string "] == '/')) ? (*request",
658 string "+=", 672 space,
659 space, 673 string "+=",
660 string (Int.toString (size has_arg)), 674 space,
661 string ", (request[0] == '/' ? ++request : NULL), ", 675 string (Int.toString (size has_arg)),
662 newline, 676 string ", ((*request)[0] == '/' ? ++*request : NULL), ",
663 677 newline,
664 if isUnboxable t then 678
665 unurlify' rf (#1 t) 679 if isUnboxable t then
666 else 680 unurlify' "(*request)" (#1 t)
667 box [string "({", 681 else
668 newline, 682 box [string "({",
669 p_typ env t, 683 newline,
670 space, 684 p_typ env t,
671 string "*tmp", 685 space,
672 space, 686 string "*tmp",
673 string "=", 687 space,
674 space, 688 string "=",
675 string "uw_malloc(ctx, sizeof(", 689 space,
676 p_typ env t, 690 string "uw_malloc(ctx, sizeof(",
677 string "));", 691 p_typ env t,
678 newline, 692 string "));",
679 string "*tmp", 693 newline,
680 space, 694 string "*tmp",
681 string "=", 695 space,
682 space, 696 string "=",
683 unurlify' rf (#1 t), 697 space,
684 string ";", 698 unurlify' "(*request)" (#1 t),
685 newline, 699 string ";",
686 string "tmp;", 700 newline,
687 newline, 701 string "tmp;",
688 string "})"], 702 newline,
689 string ")", 703 string "})"],
690 newline, 704 string ")",
691 string ":", 705 newline,
692 space, 706 string ":",
693 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x 707 space,
694 ^ "\"), NULL))));"), 708 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
695 newline], 709 ^ "\"), NULL))));"),
696 string "}", 710 newline],
697 newline, 711 string "}",
698 newline, 712 newline,
699 713 newline]);
700 string "unurlify_", 714
701 string (Int.toString i), 715 box [string "unurlify_",
702 string "();", 716 string (Int.toString i),
703 newline, 717 string ("(ctx, &" ^ request ^ ")")]
704 string "})"]
705 end 718 end
706 719
707 | TDatatype (Default, i, _) => 720 | TDatatype (Default, i, _) =>
708 if IS.member (rf, i) then 721 if IS.member (!unurlifies, i) then
709 box [string "unurlify_", 722 box [string "unurlify_",
710 string (Int.toString i), 723 string (Int.toString i),
711 string "()"] 724 string ("(ctx, &" ^ request ^ ")")]
712 else 725 else
713 let 726 let
714 val (x, xncs) = E.lookupDatatype env i 727 val (x, xncs) = E.lookupDatatype env i
715 728
716 val rf = IS.add (rf, i) 729 val () = unurlifies := IS.add (!unurlifies, i)
717 730
718 fun doEm xncs = 731 fun doEm xncs =
719 case xncs of 732 case xncs of
720 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " 733 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
721 ^ x ^ "\"), NULL)") 734 ^ x ^ "\"), NULL)")
722 | (x', n, to) :: rest => 735 | (x', n, to) :: rest =>
723 box [string "((!strncmp(request, \"", 736 box [string "((!strncmp(*request, \"",
724 string x', 737 string x',
725 string "\", ", 738 string "\", ",
726 string (Int.toString (size x')), 739 string (Int.toString (size x')),
727 string ") && (request[", 740 string ") && ((*request)[",
728 string (Int.toString (size x')), 741 string (Int.toString (size x')),
729 string "] == 0 || request[", 742 string "] == 0 || (*request)[",
730 string (Int.toString (size x')), 743 string (Int.toString (size x')),
731 string "] == '/')) ? ({", 744 string "] == '/')) ? ({",
732 newline, 745 newline,
733 string "struct", 746 string "struct",
734 space, 747 space,
745 string "=", 758 string "=",
746 space, 759 space,
747 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), 760 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
748 string ";", 761 string ";",
749 newline, 762 newline,
750 string "request", 763 string "*request",
751 space, 764 space,
752 string "+=", 765 string "+=",
753 space, 766 space,
754 string (Int.toString (size x')), 767 string (Int.toString (size x')),
755 string ";", 768 string ";",
756 newline, 769 newline,
757 string "if (request[0] == '/') ++request;", 770 string "if ((*request)[0] == '/') ++*request;",
758 newline, 771 newline,
759 case to of 772 case to of
760 NONE => box [] 773 NONE => box []
761 | SOME (t, _) => box [string "tmp->data.uw_", 774 | SOME (t, _) => box [string "tmp->data.uw_",
762 p_ident x', 775 p_ident x',
763 space, 776 space,
764 string "=", 777 string "=",
765 space, 778 space,
766 unurlify' rf t, 779 unurlify' "(*request)" t,
767 string ";", 780 string ";",
768 newline], 781 newline],
769 string "tmp;", 782 string "tmp;",
770 newline, 783 newline,
771 string "})", 784 string "})",
773 string ":", 786 string ":",
774 space, 787 space,
775 doEm rest, 788 doEm rest,
776 string ")"] 789 string ")"]
777 in 790 in
778 box [string "({", 791 addUrlHandler (box [string "static",
779 space, 792 space,
780 p_typ env (t, ErrorMsg.dummySpan), 793 p_typ env (t, ErrorMsg.dummySpan),
781 space, 794 space,
782 string "unurlify_", 795 string "unurlify_",
796 string (Int.toString i),
797 string "(uw_context ctx, char **request) {",
798 newline,
799 box [string "return",
800 space,
801 doEm xncs,
802 string ";",
803 newline],
804 string "}",
805 newline,
806 newline]);
807
808 box [string "unurlify_",
783 string (Int.toString i), 809 string (Int.toString i),
784 string "(void) {", 810 string ("(ctx, &" ^ request ^ ")")]
785 newline,
786 box [string "return",
787 space,
788 doEm xncs,
789 string ";",
790 newline],
791 string "}",
792 newline,
793 newline,
794
795 string "unurlify_",
796 string (Int.toString i),
797 string "();",
798 newline,
799 string "})"]
800 end 811 end
801 812
802 | TList (t', i) => 813 | TList (t', i) =>
803 if IS.member (rf, i) then 814 if IS.member (!unurlifies, i) then
804 box [string "unurlify_list_", 815 box [string "unurlify_list_",
805 string (Int.toString i), 816 string (Int.toString i),
806 string "()"] 817 string ("(ctx, &" ^ request ^ ")")]
807 else 818 else
808 let 819 (unurlifies := IS.add (!unurlifies, i);
809 val rf = IS.add (rf, i) 820 addUrlHandler (box [string "static",
810 in 821 space,
811 box [string "({", 822 p_typ env (t, loc),
812 space, 823 space,
813 p_typ env (t, loc), 824 string "unurlify_list_",
814 space, 825 string (Int.toString i),
815 string "unurlify_list_", 826 string "(uw_context ctx, char **request) {",
816 string (Int.toString i), 827 newline,
817 string "(void) {", 828 box [string "return ((*request)[0] == '/' ? ++*request : *request,",
818 newline, 829 newline,
819 box [string "return (request[0] == '/' ? ++request : request,", 830 string "((!strncmp(*request, \"Nil\", 3) && ((*request)[3] == 0 ",
820 newline, 831 string "|| (*request)[3] == '/')) ? (*request",
821 string "((!strncmp(request, \"Nil\", 3) && (request[3] == 0 ", 832 space,
822 string "|| request[3] == '/')) ? (request", 833 string "+=",
823 space, 834 space,
824 string "+=", 835 string "3, (*request == '/' ? *request++ = 0 : 0), NULL) : ((!strncmp(*request, \"Cons\", 4) && ((*request)[4] == 0 ",
825 space, 836 string "|| (*request)[4] == '/')) ? (*request",
826 string "3, (*request == '/' ? *request++ = 0 : 0), NULL) : ((!strncmp(request, \"Cons\", 4) && (request[4] == 0 ", 837 space,
827 string "|| request[4] == '/')) ? (request", 838 string "+=",
828 space, 839 space,
829 string "+=", 840 string "4, ((*request)[0] == '/' ? ++*request : NULL), ",
830 space, 841 newline,
831 string "4, (request[0] == '/' ? ++request : NULL), ", 842
832 newline, 843 string "({",
833 844 newline,
834 string "({", 845 p_typ env (t, loc),
835 newline, 846 space,
836 p_typ env (t, loc), 847 string "tmp",
837 space, 848 space,
838 string "tmp", 849 string "=",
839 space, 850 space,
840 string "=", 851 string "uw_malloc(ctx, sizeof(struct __uws_",
841 space, 852 string (Int.toString i),
842 string "uw_malloc(ctx, sizeof(struct __uws_", 853 string "));",
843 string (Int.toString i), 854 newline,
844 string "));", 855 string "*tmp",
845 newline, 856 space,
846 string "*tmp", 857 string "=",
847 space, 858 space,
848 string "=", 859 unurlify' "(*request)" (TRecord i),
849 space, 860 string ";",
850 unurlify' rf (TRecord i), 861 newline,
851 string ";", 862 string "tmp;",
852 newline, 863 newline,
853 string "tmp;", 864 string "})",
854 newline, 865 string ")",
855 string "})", 866 newline,
856 string ")", 867 string ":",
857 newline, 868 space,
858 string ":", 869 string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"),
859 space, 870 newline],
860 string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"), 871 string "}",
861 newline], 872 newline,
862 string "}", 873 newline]);
863 newline, 874
864 newline, 875 box [string "unurlify_list_",
865 876 string (Int.toString i),
866 string "unurlify_list_", 877 string ("(ctx, &" ^ request ^ ")")])
867 string (Int.toString i),
868 string "();",
869 newline,
870 string "})"]
871 end
872 878
873 | TOption t => 879 | TOption t =>
874 box [string "(request[0] == '/' ? ++request : request, ", 880 box [string ("(" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : " ^ request ^ ", "),
875 string "((!strncmp(request, \"None\", 4) ", 881 string ("((!strncmp(" ^ request ^ ", \"None\", 4) "),
876 string "&& (request[4] == 0 || request[4] == '/')) ", 882 string ("&& (" ^ request ^ "[4] == 0 || " ^ request ^ "[4] == '/')) "),
877 string "? (request += (request[4] == 0 ? 4 : 5), NULL) ", 883 string ("? (" ^ request ^ " += (" ^ request ^ "[4] == 0 ? 4 : 5), NULL) "),
878 string ": ((!strncmp(request, \"Some\", 4) ", 884 string (": ((!strncmp(" ^ request ^ ", \"Some\", 4) "),
879 string "&& request[4] == '/') ", 885 string ("&& " ^ request ^ "[4] == '/') "),
880 string "? (request += 5, ", 886 string ("? (" ^ request ^ " += 5, "),
881 if isUnboxable t then 887 if isUnboxable t then
882 unurlify' rf (#1 t) 888 unurlify' request (#1 t)
883 else 889 else
884 box [string "({", 890 box [string "({",
885 newline, 891 newline,
886 p_typ env t, 892 p_typ env t,
887 space, 893 space,
895 newline, 901 newline,
896 string "*tmp", 902 string "*tmp",
897 space, 903 space,
898 string "=", 904 string "=",
899 space, 905 space,
900 unurlify' rf (#1 t), 906 unurlify' request (#1 t),
901 string ";", 907 string ";",
902 newline, 908 newline,
903 string "tmp;", 909 string "tmp;",
904 newline, 910 newline,
905 string "})"], 911 string "})"],
908 string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] 914 string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]
909 915
910 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; 916 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
911 space) 917 space)
912 in 918 in
913 unurlify' IS.empty t 919 unurlify' "request" t
914 end 920 end
915 921
916 val urlify1 = ref 0 922 val urlify1 = ref 0
923
924 val urlifies = ref IS.empty
925 val urlifiesL = ref IS.empty
917 926
918 fun urlify env t = 927 fun urlify env t =
919 let 928 let
920 fun urlify' rf rfl level (t as (_, loc)) = 929 fun urlify' level (t as (_, loc)) =
921 case #1 t of 930 case #1 t of
922 TFfi ("Basis", "unit") => box [] 931 TFfi ("Basis", "unit") => box []
923 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t 932 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
924 ^ "_w(ctx, it" ^ Int.toString level ^ ");"), 933 ^ "_w(ctx, it" ^ Int.toString level ^ ");"),
925 newline] 934 newline]
958 box (if printingSinceLastSlash then 967 box (if printingSinceLastSlash then
959 [string "uw_write(ctx, \"/\");", 968 [string "uw_write(ctx, \"/\");",
960 newline] 969 newline]
961 else 970 else
962 []), 971 []),
963 urlify' rf rfl (level + 1) t, 972 urlify' (level + 1) t,
964 string "}", 973 string "}",
965 newline] :: blocks, 974 newline] :: blocks,
966 true) 975 true)
967 end) 976 end)
968 ([], false) xts 977 ([], false) xts
993 in 1002 in
994 doEm xncs 1003 doEm xncs
995 end 1004 end
996 1005
997 | TDatatype (Option, i, xncs) => 1006 | TDatatype (Option, i, xncs) =>
998 if IS.member (rf, i) then 1007 if IS.member (!urlifies, i) then
999 box [string "urlify_", 1008 box [string "urlify_",
1000 string (Int.toString i), 1009 string (Int.toString i),
1001 string "(it", 1010 string "(ctx,",
1011 space,
1012 string "it",
1002 string (Int.toString level), 1013 string (Int.toString level),
1003 string ");", 1014 string ");",
1004 newline] 1015 newline]
1005 else 1016 else
1006 let 1017 let
1011 [(no_arg, _, NONE), (has_arg, _, SOME t)] => 1022 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
1012 (no_arg, has_arg, t) 1023 (no_arg, has_arg, t)
1013 | [(has_arg, _, SOME t), (no_arg, _, NONE)] => 1024 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
1014 (no_arg, has_arg, t) 1025 (no_arg, has_arg, t)
1015 | _ => raise Fail "CjrPrint: urlify misclassified Option datatype" 1026 | _ => raise Fail "CjrPrint: urlify misclassified Option datatype"
1016
1017 val rf = IS.add (rf, i)
1018 in 1027 in
1019 box [string "({", 1028 urlifies := IS.add (!urlifies, i);
1029 addUrlHandler (box [string "static",
1030 space,
1031 string "void",
1032 space,
1033 string "urlify_",
1034 string (Int.toString i),
1035 string "(uw_context ctx,",
1036 space,
1037 p_typ env t,
1038 space,
1039 if isUnboxable t then
1040 box []
1041 else
1042 string "*",
1043 string "it0) {",
1044 newline,
1045 box [string "if (it0) {",
1046 newline,
1047 if isUnboxable t then
1048 urlify' 0 t
1049 else
1050 box [p_typ env t,
1051 space,
1052 string "it1",
1053 space,
1054 string "=",
1055 space,
1056 string "*it0;",
1057 newline,
1058 string "uw_write(ctx, \"",
1059 string has_arg,
1060 string "/\");",
1061 newline,
1062 urlify' 1 t,
1063 string ";",
1064 newline],
1065 string "} else {",
1066 box [newline,
1067 string "uw_write(ctx, \"",
1068 string no_arg,
1069 string "\");",
1070 newline],
1071 string "}",
1072 newline],
1073 string "}",
1074 newline,
1075 newline]);
1076
1077 box [string "urlify_",
1078 string (Int.toString i),
1079 string "(ctx,",
1020 space, 1080 space,
1021 string "void", 1081 string "it",
1022 space,
1023 string "urlify_",
1024 string (Int.toString i),
1025 string "(",
1026 p_typ env t,
1027 space,
1028 if isUnboxable t then
1029 box []
1030 else
1031 string "*",
1032 string "it0) {",
1033 newline,
1034 box [string "if (it0) {",
1035 newline,
1036 if isUnboxable t then
1037 urlify' rf rfl 0 t
1038 else
1039 box [p_typ env t,
1040 space,
1041 string "it1",
1042 space,
1043 string "=",
1044 space,
1045 string "*it0;",
1046 newline,
1047 string "uw_write(ctx, \"",
1048 string has_arg,
1049 string "/\");",
1050 newline,
1051 urlify' rf rfl 1 t,
1052 string ";",
1053 newline],
1054 string "} else {",
1055 box [newline,
1056 string "uw_write(ctx, \"",
1057 string no_arg,
1058 string "\");",
1059 newline],
1060 string "}",
1061 newline],
1062 string "}",
1063 newline,
1064 newline,
1065
1066 string "urlify_",
1067 string (Int.toString i),
1068 string "(it",
1069 string (Int.toString level), 1082 string (Int.toString level),
1070 string ");", 1083 string ");",
1071 newline,
1072 string "});",
1073 newline] 1084 newline]
1074 end 1085 end
1075 1086
1076 | TDatatype (Default, i, _) => 1087 | TDatatype (Default, i, _) =>
1077 if IS.member (rf, i) then 1088 if IS.member (!urlifies, i) then
1078 box [string "urlify_", 1089 box [string "urlify_",
1079 string (Int.toString i), 1090 string (Int.toString i),
1080 string "(it", 1091 string "(ctx,",
1092 space,
1093 string "it",
1081 string (Int.toString level), 1094 string (Int.toString level),
1082 string ");", 1095 string ");",
1083 newline] 1096 newline]
1084 else 1097 else
1085 let 1098 let
1086 val (x, xncs) = E.lookupDatatype env i 1099 val (x, xncs) = E.lookupDatatype env i
1087 1100
1088 val rf = IS.add (rf, i) 1101 val () = urlifies := IS.add (!urlifies, i)
1089 1102
1090 fun doEm xncs = 1103 fun doEm xncs =
1091 case xncs of 1104 case xncs of
1092 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " 1105 [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
1093 ^ x ^ " (%d)\", it0->data);"), 1106 ^ x ^ " (%d)\", it0->data);"),
1118 space, 1131 space,
1119 string "it0->data.uw_", 1132 string "it0->data.uw_",
1120 string x', 1133 string x',
1121 string ";", 1134 string ";",
1122 newline, 1135 newline,
1123 urlify' rf rfl 1 t, 1136 urlify' 1 t,
1124 newline], 1137 newline],
1125 string "} else {", 1138 string "} else {",
1126 newline, 1139 newline,
1127 box [doEm rest, 1140 box [doEm rest,
1128 newline], 1141 newline],
1129 string "}", 1142 string "}",
1130 newline] 1143 newline]
1131 in 1144 in
1132 box [string "({", 1145 addUrlHandler (box [string "static",
1146 space,
1147 string "void",
1148 space,
1149 string "urlify_",
1150 string (Int.toString i),
1151 string "(uw_context ctx,",
1152 space,
1153 p_typ env t,
1154 space,
1155 string "it0) {",
1156 newline,
1157 box [doEm xncs,
1158 newline],
1159 newline,
1160 string "}",
1161 newline,
1162 newline]);
1163
1164 box [string "urlify_",
1165 string (Int.toString i),
1166 string "(ctx,",
1133 space, 1167 space,
1134 string "void", 1168 string "it",
1135 space,
1136 string "urlify_",
1137 string (Int.toString i),
1138 string "(",
1139 p_typ env t,
1140 space,
1141 string "it0) {",
1142 newline,
1143 box [doEm xncs,
1144 newline],
1145 newline,
1146 string "}",
1147 newline,
1148
1149 string "urlify_",
1150 string (Int.toString i),
1151 string "(it",
1152 string (Int.toString level), 1169 string (Int.toString level),
1153 string ");", 1170 string ");",
1154 newline,
1155 string "});",
1156 newline] 1171 newline]
1157 end 1172 end
1158 1173
1159 | TOption t => 1174 | TOption t =>
1160 box [string "if (it", 1175 box [string "if (it",
1161 string (Int.toString level), 1176 string (Int.toString level),
1162 string ") {", 1177 string ") {",
1163 if isUnboxable t then 1178 if isUnboxable t then
1164 box [string "uw_write(ctx, \"Some/\");", 1179 box [string "uw_write(ctx, \"Some/\");",
1165 newline, 1180 newline,
1166 urlify' rf rfl level t] 1181 urlify' level t]
1167 else 1182 else
1168 box [p_typ env t, 1183 box [p_typ env t,
1169 space, 1184 space,
1170 string "it", 1185 string "it",
1171 string (Int.toString (level + 1)), 1186 string (Int.toString (level + 1)),
1176 string (Int.toString level), 1191 string (Int.toString level),
1177 string ";", 1192 string ";",
1178 newline, 1193 newline,
1179 string "uw_write(ctx, \"Some/\");", 1194 string "uw_write(ctx, \"Some/\");",
1180 newline, 1195 newline,
1181 urlify' rf rfl (level + 1) t, 1196 urlify' (level + 1) t,
1182 string ";", 1197 string ";",
1183 newline], 1198 newline],
1184 string "} else {", 1199 string "} else {",
1185 box [newline, 1200 box [newline,
1186 string "uw_write(ctx, \"None\");", 1201 string "uw_write(ctx, \"None\");",
1187 newline], 1202 newline],
1188 string "}", 1203 string "}",
1189 newline] 1204 newline]
1190 1205
1191 | TList (t, i) => 1206 | TList (t, i) =>
1192 if IS.member (rfl, i) then 1207 if IS.member (!urlifiesL, i) then
1193 box [string "urlifyl_", 1208 box [string "urlifyl_",
1194 string (Int.toString i), 1209 string (Int.toString i),
1195 string "(it", 1210 string "(ctx,",
1211 space,
1212 string "it",
1196 string (Int.toString level), 1213 string (Int.toString level),
1197 string ");", 1214 string ");",
1198 newline] 1215 newline]
1199 else 1216 else
1200 let 1217 (urlifiesL := IS.add (!urlifiesL, i);
1201 val rfl = IS.add (rfl, i) 1218 addUrlHandler (box [string "static",
1202 in 1219 space,
1203 box [string "({", 1220 string "void",
1204 space, 1221 space,
1205 string "void", 1222 string "urlifyl_",
1206 space, 1223 string (Int.toString i),
1207 string "urlifyl_", 1224 string "(uw_context ctx,",
1208 string (Int.toString i), 1225 space,
1209 string "(struct __uws_", 1226 string "struct __uws_",
1210 string (Int.toString i), 1227 string (Int.toString i),
1211 space, 1228 space,
1212 string "*it0) {", 1229 string "*it0) {",
1213 newline, 1230 newline,
1214 box [string "if (it0) {", 1231 box [string "if (it0) {",
1215 newline, 1232 newline,
1216 p_typ env t, 1233 p_typ env t,
1217 space, 1234 space,
1218 string "it1", 1235 string "it1",
1219 space, 1236 space,
1220 string "=", 1237 string "=",
1221 space, 1238 space,
1222 string "it0->__uwf_1;", 1239 string "it0->__uwf_1;",
1223 newline, 1240 newline,
1224 string "uw_write(ctx, \"Cons/\");", 1241 string "uw_write(ctx, \"Cons/\");",
1225 newline, 1242 newline,
1226 urlify' rf rfl 1 t, 1243 urlify' 1 t,
1227 string ";", 1244 string ";",
1228 newline, 1245 newline,
1229 string "uw_write(ctx, \"/\");", 1246 string "uw_write(ctx, \"/\");",
1230 newline, 1247 newline,
1231 string "urlifyl_", 1248 string "urlifyl_",
1232 string (Int.toString i), 1249 string (Int.toString i),
1233 string "(it0->__uwf_2);", 1250 string "(ctx, it0->__uwf_2);",
1234 newline, 1251 newline,
1235 string "} else {", 1252 string "} else {",
1236 newline, 1253 newline,
1237 box [string "uw_write(ctx, \"Nil\");", 1254 box [string "uw_write(ctx, \"Nil\");",
1238 newline], 1255 newline],
1239 string "}", 1256 string "}",
1240 newline], 1257 newline],
1241 string "}", 1258 string "}",
1242 newline, 1259 newline,
1243 newline, 1260 newline]);
1244 1261
1245 string "urlifyl_", 1262 box [string "urlifyl_",
1246 string (Int.toString i), 1263 string (Int.toString i),
1247 string "(it", 1264 string "(ctx,",
1248 string (Int.toString level), 1265 space,
1249 string ");", 1266 string "it",
1250 newline, 1267 string (Int.toString level),
1251 string "});", 1268 string ");",
1252 newline] 1269 newline])
1253 end 1270
1254
1255 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; 1271 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
1256 space) 1272 space)
1257 in 1273 in
1258 urlify' IS.empty IS.empty 0 t 1274 urlify' 0 t
1259 end 1275 end
1260 1276
1261 fun sql_type_in env (tAll as (t, loc)) = 1277 fun sql_type_in env (tAll as (t, loc)) =
1262 case t of 1278 case t of
1263 TFfi ("Basis", "int") => Int 1279 TFfi ("Basis", "int") => Int
1336 string "));", 1352 string "));",
1337 newline, 1353 newline,
1338 string "*tmp", 1354 string "*tmp",
1339 space, 1355 space,
1340 string "=", 1356 string "=",
1357 space,
1341 p_exp' par env e, 1358 p_exp' par env e,
1342 string ";", 1359 string ";",
1343 newline, 1360 newline,
1344 string "tmp;", 1361 string "tmp;",
1345 newline, 1362 newline,
1402 string "));", 1419 string "));",
1403 newline, 1420 newline,
1404 string "*tmp", 1421 string "*tmp",
1405 space, 1422 space,
1406 string "=", 1423 string "=",
1424 space,
1407 p_exp' par env e, 1425 p_exp' par env e,
1408 string ";", 1426 string ";",
1409 newline, 1427 newline,
1410 string "tmp;", 1428 string "tmp;",
1411 newline, 1429 newline,
1561 newline, 1579 newline,
1562 newline, 1580 newline,
1563 foldr (fn ((p, e), body) => 1581 foldr (fn ((p, e), body) =>
1564 let 1582 let
1565 val pm = p_patMatch (env, "disc") p 1583 val pm = p_patMatch (env, "disc") p
1566 val (pb, env) = p_patBind (env, "disc") p 1584 val (pb, env') = p_patBind (env, "disc") p
1567 in 1585 in
1568 box [pm, 1586 box [pm,
1569 space, 1587 space,
1570 string "?", 1588 string "?",
1571 space, 1589 space,
1572 box [string "({", 1590 if E.countERels env' = E.countERels env then
1573 pb, 1591 p_exp env e
1574 p_exp env e, 1592 else
1575 string ";", 1593 box [string "({",
1576 newline, 1594 pb,
1577 string "})"], 1595 p_exp env' e,
1596 string ";",
1597 newline,
1598 string "})"],
1578 newline, 1599 newline,
1579 space, 1600 space,
1580 string ":", 1601 string ":",
1581 space, 1602 space,
1582 body] 1603 body]
2223 "Sig" 2244 "Sig"
2224 end 2245 end
2225 2246
2226 fun p_file env (ds, ps) = 2247 fun p_file env (ds, ps) =
2227 let 2248 let
2249 val () = (clearUrlHandlers ();
2250 unurlifies := IS.empty;
2251 urlifies := IS.empty;
2252 urlifiesL := IS.empty)
2253
2228 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 2254 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
2229 (p_decl env d, 2255 let
2230 E.declBinds env d)) 2256 val d' = p_decl env d
2257 in
2258 (box (List.revAppend (latestUrlHandlers (), [d'])),
2259 E.declBinds env d)
2260 end)
2231 env ds 2261 env ds
2232 2262
2233 fun flatFields always (t : typ) = 2263 fun flatFields always (t : typ) =
2234 case #1 t of 2264 case #1 t of
2235 TRecord i => 2265 TRecord i =>
2738 newline, 2768 newline,
2739 string "}"] 2769 string "}"]
2740 ] 2770 ]
2741 end 2771 end
2742 2772
2743 val pds' = map p_page ps 2773 val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) =>
2744 2774 let
2775 val p' = p_page p
2776 in
2777 (p', latestUrlHandlers () @ handlers)
2778 end) [] ps
2779
2745 val hasDb = ref false 2780 val hasDb = ref false
2746 val tables = ref [] 2781 val tables = ref []
2747 val views = ref [] 2782 val views = ref []
2748 val sequences = ref [] 2783 val sequences = ref []
2749 val dbstring = ref "" 2784 val dbstring = ref ""
3010 string "return uw_Basis_makeSigString(ctx, r);", 3045 string "return uw_Basis_makeSigString(ctx, r);",
3011 newline], 3046 newline],
3012 string "}", 3047 string "}",
3013 newline, 3048 newline,
3014 newline, 3049 newline,
3050
3051 box (rev handlers),
3015 3052
3016 string "static void uw_handle(uw_context ctx, char *request) {", 3053 string "static void uw_handle(uw_context ctx, char *request) {",
3017 newline, 3054 newline,
3018 string "if (!strcmp(request, \"", 3055 string "if (!strcmp(request, \"",
3019 string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), 3056 string (OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),