Mercurial > urweb

comparison src/cjr_print.sml @ 610:c41b2abf156b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Reading and displaying value via AJAX
author Adam Chlipala <adamc@hcoop.net>
date Sun, 15 Feb 2009 10:54:00 -0500
parents 56aaa1941dad
children a8704dfc58cf
comparison
equal deleted inserted replaced
609:56aaa1941dad 610:c41b2abf156b
839 space) 839 space)
840 in 840 in
841 unurlify' IS.empty t 841 unurlify' IS.empty t
842 end 842 end
843 843
844 fun urlify env t =
845 let
846 fun urlify' rf level (t as (_, loc)) =
847 case #1 t of
848 TFfi ("Basis", "unit") => box []
849 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
850 ^ "_w(ctx, it" ^ Int.toString level ^ ");"),
851 newline,
852 string "uw_write(ctx, \"/\");",
853 newline]
854
855 | TRecord 0 => box []
856 | TRecord i =>
857 let
858 val xts = E.lookupStruct env i
859 in
860 p_list_sep newline
861 (fn (x, t) =>
862 box [string "{",
863 newline,
864 p_typ env t,
865 space,
866 string ("it" ^ Int.toString (level + 1)),
867 space,
868 string "=",
869 space,
870 string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
871 newline,
872 urlify' rf (level + 1) t,
873 string "}"])
874 xts
875 end
876
877 | TDatatype (Enum, i, _) => box []
878 (*let
879 val (x, xncs) = E.lookupDatatype env i
880
881 fun doEm xncs =
882 case xncs of
883 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
884 ^ x ^ "\"), (enum __uwe_"
885 ^ x ^ "_" ^ Int.toString i ^ ")0)")
886 | (x', n, to) :: rest =>
887 box [string "((!strncmp(request, \"",
888 string x',
889 string "\", ",
890 string (Int.toString (size x')),
891 string ") && (request[",
892 string (Int.toString (size x')),
893 string "] == 0 || request[",
894 string (Int.toString (size x')),
895 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
896 space,
897 string ":",
898 space,
899 doEm rest,
900 string ")"]
901 in
902 doEm xncs
903 end*)
904
905 | TDatatype (Option, i, xncs) => box []
906 (*if IS.member (rf, i) then
907 box [string "unurlify_",
908 string (Int.toString i),
909 string "()"]
910 else
911 let
912 val (x, _) = E.lookupDatatype env i
913
914 val (no_arg, has_arg, t) =
915 case !xncs of
916 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
917 (no_arg, has_arg, t)
918 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
919 (no_arg, has_arg, t)
920 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
921
922 val rf = IS.add (rf, i)
923 in
924 box [string "({",
925 space,
926 p_typ env t,
927 space,
928 string "*unurlify_",
929 string (Int.toString i),
930 string "(void) {",
931 newline,
932 box [string "return (request[0] == '/' ? ++request : request,",
933 newline,
934 string "((!strncmp(request, \"",
935 string no_arg,
936 string "\", ",
937 string (Int.toString (size no_arg)),
938 string ") && (request[",
939 string (Int.toString (size no_arg)),
940 string "] == 0 || request[",
941 string (Int.toString (size no_arg)),
942 string "] == '/')) ? (request",
943 space,
944 string "+=",
945 space,
946 string (Int.toString (size no_arg)),
947 string ", NULL) : ((!strncmp(request, \"",
948 string has_arg,
949 string "\", ",
950 string (Int.toString (size has_arg)),
951 string ") && (request[",
952 string (Int.toString (size has_arg)),
953 string "] == 0 || request[",
954 string (Int.toString (size has_arg)),
955 string "] == '/')) ? (request",
956 space,
957 string "+=",
958 space,
959 string (Int.toString (size has_arg)),
960 string ", (request[0] == '/' ? ++request : NULL), ",
961 newline,
962
963 if isUnboxable t then
964 unurlify' rf (#1 t)
965 else
966 box [string "({",
967 newline,
968 p_typ env t,
969 space,
970 string "*tmp",
971 space,
972 string "=",
973 space,
974 string "uw_malloc(ctx, sizeof(",
975 p_typ env t,
976 string "));",
977 newline,
978 string "*tmp",
979 space,
980 string "=",
981 space,
982 unurlify' rf (#1 t),
983 string ";",
984 newline,
985 string "tmp;",
986 newline,
987 string "})"],
988 string ")",
989 newline,
990 string ":",
991 space,
992 string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
993 ^ "\"), NULL))));"),
994 newline],
995 string "}",
996 newline,
997 newline,
998
999 string "unurlify_",
1000 string (Int.toString i),
1001 string "();",
1002 newline,
1003 string "})"]
1004 end*)
1005
1006 | TDatatype (Default, i, _) => box []
1007 (*if IS.member (rf, i) then
1008 box [string "unurlify_",
1009 string (Int.toString i),
1010 string "()"]
1011 else
1012 let
1013 val (x, xncs) = E.lookupDatatype env i
1014
1015 val rf = IS.add (rf, i)
1016
1017 fun doEm xncs =
1018 case xncs of
1019 [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
1020 ^ x ^ "\"), NULL)")
1021 | (x', n, to) :: rest =>
1022 box [string "((!strncmp(request, \"",
1023 string x',
1024 string "\", ",
1025 string (Int.toString (size x')),
1026 string ") && (request[",
1027 string (Int.toString (size x')),
1028 string "] == 0 || request[",
1029 string (Int.toString (size x')),
1030 string "] == '/')) ? ({",
1031 newline,
1032 string "struct",
1033 space,
1034 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
1035 space,
1036 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
1037 string x,
1038 string "_",
1039 string (Int.toString i),
1040 string "));",
1041 newline,
1042 string "tmp->tag",
1043 space,
1044 string "=",
1045 space,
1046 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
1047 string ";",
1048 newline,
1049 string "request",
1050 space,
1051 string "+=",
1052 space,
1053 string (Int.toString (size x')),
1054 string ";",
1055 newline,
1056 string "if (request[0] == '/') ++request;",
1057 newline,
1058 case to of
1059 NONE => box []
1060 | SOME (t, _) => box [string "tmp->data.uw_",
1061 p_ident x',
1062 space,
1063 string "=",
1064 space,
1065 unurlify' rf t,
1066 string ";",
1067 newline],
1068 string "tmp;",
1069 newline,
1070 string "})",
1071 space,
1072 string ":",
1073 space,
1074 doEm rest,
1075 string ")"]
1076 in
1077 box [string "({",
1078 space,
1079 p_typ env (t, ErrorMsg.dummySpan),
1080 space,
1081 string "unurlify_",
1082 string (Int.toString i),
1083 string "(void) {",
1084 newline,
1085 box [string "return",
1086 space,
1087 doEm xncs,
1088 string ";",
1089 newline],
1090 string "}",
1091 newline,
1092 newline,
1093
1094 string "unurlify_",
1095 string (Int.toString i),
1096 string "();",
1097 newline,
1098 string "})"]
1099 end*)
1100
1101 | TOption t => box []
1102 (*box [string "(request[0] == '/' ? ++request : request, ",
1103 string "((!strncmp(request, \"None\", 4) ",
1104 string "&& (request[4] == 0 || request[4] == '/')) ",
1105 string "? (request += 4, NULL) ",
1106 string ": ((!strncmp(request, \"Some\", 4) ",
1107 string "&& request[4] == '/') ",
1108 string "? (request += 5, ",
1109 if isUnboxable t then
1110 unurlify' rf (#1 t)
1111 else
1112 box [string "({",
1113 newline,
1114 p_typ env t,
1115 space,
1116 string "*tmp",
1117 space,
1118 string "=",
1119 space,
1120 string "uw_malloc(ctx, sizeof(",
1121 p_typ env t,
1122 string "));",
1123 newline,
1124 string "*tmp",
1125 space,
1126 string "=",
1127 space,
1128 unurlify' rf (#1 t),
1129 string ";",
1130 newline,
1131 string "tmp;",
1132 newline,
1133 string "})"],
1134 string ") :",
1135 space,
1136 string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"]*)
1137
1138 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
1139 space)
1140 in
1141 urlify' IS.empty 0 t
1142 end
1143
844 fun p_exp' par env (e, loc) = 1144 fun p_exp' par env (e, loc) =
845 case e of 1145 case e of
846 EPrim p => Prim.p_t_GCC p 1146 EPrim p => Prim.p_t_GCC p
847 | ERel n => p_rel env n 1147 | ERel n => p_rel env n
848 | ENamed n => p_enamed env n 1148 | ENamed n => p_enamed env n
2053 string ";", 2353 string ";",
2054 newline, 2354 newline,
2055 string "if (*request == '/') ++request;", 2355 string "if (*request == '/') ++request;",
2056 newline, 2356 newline,
2057 box (case ek of 2357 box (case ek of
2058 Core.Rpc => [] 2358 Core.Rpc => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
2359 newline]
2059 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", 2360 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
2060 newline, 2361 newline,
2061 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", 2362 string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
2062 newline, 2363 newline,
2063 string "uw_write(ctx, \"<html>\");", 2364 string "uw_write(ctx, \"<html>\");",
2076 newline]) ts), 2377 newline]) ts),
2077 defInputs, 2378 defInputs,
2078 box (case ek of 2379 box (case ek of
2079 Core.Rpc => [p_typ env ran, 2380 Core.Rpc => [p_typ env ran,
2080 space, 2381 space,
2081 string "res", 2382 string "it0",
2082 space, 2383 space,
2083 string "=", 2384 string "=",
2084 space] 2385 space]
2085 | _ => []), 2386 | _ => []),
2086 p_enamed env n, 2387 p_enamed env n,
2091 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), 2392 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
2092 inputsVar, 2393 inputsVar,
2093 string ", uw_unit_v);", 2394 string ", uw_unit_v);",
2094 newline, 2395 newline,
2095 box (case ek of 2396 box (case ek of
2096 Core.Rpc => [] 2397 Core.Rpc => [urlify env ran]
2097 | _ => [string "uw_write(ctx, \"</html>\");", 2398 | _ => [string "uw_write(ctx, \"</html>\");",
2098 newline]), 2399 newline]),
2099 string "return;", 2400 string "return;",
2100 newline, 2401 newline,
2101 string "}", 2402 string "}",