Mercurial > urweb

comparison src/jscomp.sml @ 815:493f44759879

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Redo Jscomp
author Adam Chlipala <adamc@hcoop.net>
date Sun, 17 May 2009 18:41:43 -0400
parents 7b380e2b9e68
children 395a5d450cc0
comparison
equal deleted inserted replaced
814:3f3b211f9bca 815:493f44759879
124 andalso cu (inner + 2) body 124 andalso cu (inner + 2) body
125 andalso cu inner initial 125 andalso cu inner initial
126 | EDml e => cu inner e 126 | EDml e => cu inner e
127 | ENextval e => cu inner e 127 | ENextval e => cu inner e
128 | EUnurlify (e, _) => cu inner e 128 | EUnurlify (e, _) => cu inner e
129 | EJavaScript (_, e, _) => cu inner e 129 | EJavaScript (_, e) => cu inner e
130 | ESignalReturn e => cu inner e 130 | ESignalReturn e => cu inner e
131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
132 | ESignalSource e => cu inner e 132 | ESignalSource e => cu inner e
133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek 133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek 134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek
167 bind = fn (inner, b) => 167 bind = fn (inner, b) =>
168 case b of 168 case b of
169 U.Exp.RelE _ => inner+1 169 U.Exp.RelE _ => inner+1
170 | _ => inner} 170 | _ => inner}
171 171
172 val desourceify' = 172 exception CantEmbed of typ
173 U.Exp.map {typ = fn t => t, 173
174 exp = fn e =>
175 case e of
176 EJavaScript (_, e, _) => #1 e
177 | _ => e}
178
179 val desourceify =
180 U.File.map {typ = fn t => t,
181 exp = fn e =>
182 case e of
183 EJavaScript (m, e, eo) => EJavaScript (m, desourceify' e, eo)
184 | _ => e,
185 decl = fn d => d}
186
187 fun process file = 174 fun process file =
188 let 175 let
189 val (someTs, nameds) = 176 val (someTs, nameds) =
190 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) 177 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
191 | ((DValRec vis, _), (someTs, nameds)) => 178 | ((DValRec vis, _), (someTs, nameds)) =>
385 maxName = #maxName st} 372 maxName = #maxName st}
386 in 373 in
387 ((EApp ((ENamed n', loc), e), loc), st) 374 ((EApp ((ENamed n', loc), e), loc), st)
388 end) 375 end)
389 376
390 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; 377 | _ => raise CantEmbed t
378 (*(EM.errorAt loc "Don't know how to embed type in JavaScript";
391 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; 379 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
392 (str loc "ERROR", st)) 380 (str loc "ERROR", st))*)
393 381
394 fun unurlifyExp loc (t : typ, st) = 382 fun unurlifyExp loc (t : typ, st) =
395 case #1 t of 383 case #1 t of
396 TRecord [] => ("null", st) 384 TRecord [] => ("null", st)
397 | TRecord [(x, t)] => 385 | TRecord [(x, t)] =>
771 in 759 in
772 (str name, st) 760 (str name, st)
773 end 761 end
774 | EFfiApp (m, x, args) => 762 | EFfiApp (m, x, args) =>
775 let 763 let
776 val args =
777 case (m, x, args) of
778 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) =>
779 (foundJavaScript := true; [e])
780 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) =>
781 (foundJavaScript := true; [e1, e2])
782 | _ => args
783
784 val name = case Settings.jsFunc (m, x) of 764 val name = case Settings.jsFunc (m, x) of
785 NONE => (EM.errorAt loc ("Unsupported FFI function " 765 NONE => (EM.errorAt loc ("Unsupported FFI function "
786 ^ x ^ " in JavaScript"); 766 ^ x ^ " in JavaScript");
787 "ERROR") 767 "ERROR")
788 | SOME s => s 768 | SOME s => s
983 str ",", 963 str ",",
984 e2, 964 e2,
985 str ")"], st) 965 str ")"], st)
986 end 966 end
987 967
988 | EJavaScript (Source _, _, SOME _) => 968 | EJavaScript (Source _, e) =>
989 (foundJavaScript := true; 969 (foundJavaScript := true;
990 (e, st)) 970 jsE inner (e, st))
991 | EJavaScript (_, _, SOME e) => 971 | EJavaScript (_, e) =>
992 (foundJavaScript := true; 972 let
993 (strcat [str "cs(function(){return ", 973 val (e, st) = jsE inner (e, st)
994 compact inner e, 974 in
995 str "})"], 975 foundJavaScript := true;
996 st)) 976 (strcat [str "cs(function(){return ",
977 compact inner e,
978 str "})"],
979 st)
980 end
997 981
998 | EClosure _ => unsupported "EClosure" 982 | EClosure _ => unsupported "EClosure"
999 | EQuery _ => unsupported "Query" 983 | EQuery _ => unsupported "Query"
1000 | EDml _ => unsupported "DML" 984 | EDml _ => unsupported "DML"
1001 | ENextval _ => unsupported "Nextval" 985 | ENextval _ => unsupported "Nextval"
1002 | EUnurlify _ => unsupported "EUnurlify" 986 | EUnurlify _ => unsupported "EUnurlify"
1003 | EReturnBlob _ => unsupported "EUnurlify" 987 | EReturnBlob _ => unsupported "EUnurlify"
1004 | EJavaScript (_, e, _) =>
1005 let
1006 val (e, st) = jsE inner (e, st)
1007 in
1008 foundJavaScript := true;
1009 (strcat [str "cs(function(){return ",
1010 e,
1011 str "})"],
1012 st)
1013 end
1014 988
1015 | ESignalReturn e => 989 | ESignalReturn e =>
1016 let 990 let
1017 val (e, st) = jsE inner (e, st) 991 val (e, st) = jsE inner (e, st)
1018 in 992 in
1092 end 1066 end
1093 in 1067 in
1094 jsE 1068 jsE
1095 end 1069 end
1096 1070
1097 val decl : state -> decl -> decl * state = 1071
1098 U.Decl.foldMapB {typ = fn x => x, 1072 fun patBinds ((p, _), env) =
1099 exp = fn (env, e, st) => 1073 case p of
1100 let 1074 PWild => env
1101 fun doCode m env e = 1075 | PVar (_, t) => t :: env
1102 let 1076 | PPrim _ => env
1103 val len = length env 1077 | PCon (_, _, NONE) => env
1104 fun str s = (EPrim (Prim.String s), #2 e) 1078 | PCon (_, _, SOME p) => patBinds (p, env)
1105 1079 | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts
1106 val locals = List.tabulate 1080 | PNone _ => env
1107 (varDepth e, 1081 | PSome (_, p) => patBinds (p, env)
1108 fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) 1082
1109 val old = e 1083 fun exp outer (e as (_, loc), st) =
1110 val (e, st) = jsExp m env 0 (e, st) 1084 ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*)
1111 val e = 1085 case #1 e of
1112 case locals of 1086 EPrim _ => (e, st)
1113 [] => e 1087 | ERel _ => (e, st)
1114 | _ => 1088 | ENamed _ => (e, st)
1115 strcat (#2 e) (str "(function(){" 1089 | ECon (_, _, NONE) => (e, st)
1116 :: locals 1090 | ECon (dk, pc, SOME e) =>
1117 @ [str "return ", 1091 let
1118 e, 1092 val (e, st) = exp outer (e, st)
1119 str "}())"]) 1093 in
1120 in 1094 ((ECon (dk, pc, SOME e), loc), st)
1121 (*Print.prefaces "jsify" [("old", MonoPrint.p_exp MonoEnv.empty old), 1095 end
1122 ("new", MonoPrint.p_exp MonoEnv.empty e)];*) 1096 | ENone _ => (e, st)
1123 (EJavaScript (m, old, SOME e), st) 1097 | ESome (t, e) =>
1124 end 1098 let
1125 in 1099 val (e, st) = exp outer (e, st)
1126 case e of 1100 in
1127 (*EJavaScript (m as Source t, orig, NONE) => 1101 ((ESome (t, e), loc), st)
1128 let 1102 end
1129 val loc = #2 orig 1103 | EFfi _ => (e, st)
1130 val (e, st) = doCode m (t :: env) (ERel 0, loc) 1104 | EFfiApp (m, x, es) =>
1131 in 1105 let
1132 (ELet ("x", t, orig, (e, loc)), st) 1106 val (es, st) = ListUtil.foldlMap (exp outer) st es
1133 end 1107 in
1134 |*) EJavaScript (m, orig, NONE) => 1108 ((EFfiApp (m, x, es), loc), st)
1135 (foundJavaScript := true; 1109 end
1136 doCode m env orig) 1110 | EApp (e1, e2) =>
1137 | _ => (e, st) 1111 let
1138 end, 1112 val (e1, st) = exp outer (e1, st)
1139 decl = fn (_, e, st) => (e, st), 1113 val (e2, st) = exp outer (e2, st)
1140 bind = fn (env, U.Decl.RelE (_, t)) => t :: env 1114 in
1141 | (env, _) => env} 1115 ((EApp (e1, e2), loc), st)
1142 [] 1116 end
1117 | EAbs (x, dom, ran, e) =>
1118 let
1119 val (e, st) = exp (dom :: outer) (e, st)
1120 in
1121 ((EAbs (x, dom, ran, e), loc), st)
1122 end
1123
1124 | EUnop (s, e) =>
1125 let
1126 val (e, st) = exp outer (e, st)
1127 in
1128 ((EUnop (s, e), loc), st)
1129 end
1130 | EBinop (s, e1, e2) =>
1131 let
1132 val (e1, st) = exp outer (e1, st)
1133 val (e2, st) = exp outer (e2, st)
1134 in
1135 ((EBinop (s, e1, e2), loc), st)
1136 end
1137
1138 | ERecord xets =>
1139 let
1140 val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
1141 let
1142 val (e, st) = exp outer (e, st)
1143 in
1144 ((x, e, t), st)
1145 end) st xets
1146 in
1147 ((ERecord xets, loc), st)
1148 end
1149 | EField (e, s) =>
1150 let
1151 val (e, st) = exp outer (e, st)
1152 in
1153 ((EField (e, s), loc), st)
1154 end
1155
1156 | ECase (e, pes, ts) =>
1157 let
1158 val (e, st) = exp outer (e, st)
1159 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
1160 let
1161 val (e, st) = exp (patBinds (p, outer)) (e, st)
1162 in
1163 ((p, e), st)
1164 end) st pes
1165 in
1166 ((ECase (e, pes, ts), loc), st)
1167 end
1168
1169 | EStrcat (e1, e2) =>
1170 let
1171 val (e1, st) = exp outer (e1, st)
1172 val (e2, st) = exp outer (e2, st)
1173 in
1174 ((EStrcat (e1, e2), loc), st)
1175 end
1176
1177 | EError (e, t) =>
1178 let
1179 val (e, st) = exp outer (e, st)
1180 in
1181 ((EError (e, t), loc), st)
1182 end
1183 | EReturnBlob {blob, mimeType, t} =>
1184 let
1185 val (blob, st) = exp outer (blob, st)
1186 val (mimeType, st) = exp outer (mimeType, st)
1187 in
1188 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
1189 end
1190
1191 | EWrite e =>
1192 let
1193 val (e, st) = exp outer (e, st)
1194 in
1195 ((EWrite e, loc), st)
1196 end
1197 | ESeq (e1, e2) =>
1198 let
1199 val (e1, st) = exp outer (e1, st)
1200 val (e2, st) = exp outer (e2, st)
1201 in
1202 ((ESeq (e1, e2), loc), st)
1203 end
1204 | ELet (x, t, e1, e2) =>
1205 let
1206 val (e1, st) = exp outer (e1, st)
1207 val (e2, st) = exp (t :: outer) (e2, st)
1208 in
1209 ((ELet (x, t, e1, e2), loc), st)
1210 end
1211
1212 | EClosure (n, es) =>
1213 let
1214 val (es, st) = ListUtil.foldlMap (exp outer) st es
1215 in
1216 ((EClosure (n, es), loc), st)
1217 end
1218
1219 | EQuery {exps, tables, state, query, body, initial} =>
1220 let
1221 val (query, st) = exp outer (query, st)
1222 val (body, st) = exp outer (body, st)
1223 val (initial, st) = exp outer (initial, st)
1224 in
1225 ((EQuery {exps = exps, tables = tables, state = state,
1226 query = query, body = body, initial = initial}, loc), st)
1227 end
1228 | EDml e =>
1229 let
1230 val (e, st) = exp outer (e, st)
1231 in
1232 ((EDml e, loc), st)
1233 end
1234 | ENextval e =>
1235 let
1236 val (e, st) = exp outer (e, st)
1237 in
1238 ((ENextval e, loc), st)
1239 end
1240
1241 | EUnurlify (e, t) =>
1242 let
1243 val (e, st) = exp outer (e, st)
1244 in
1245 ((EUnurlify (e, t), loc), st)
1246 end
1247
1248 | EJavaScript (m, e') =>
1249 (let
1250 val len = length outer
1251 fun str s = (EPrim (Prim.String s), #2 e')
1252
1253 val locals = List.tabulate
1254 (varDepth e',
1255 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
1256
1257 val (e', st) = jsExp m outer 0 (e', st)
1258
1259 val e' =
1260 case locals of
1261 [] => e'
1262 | _ =>
1263 strcat (#2 e') (str "(function(){"
1264 :: locals
1265 @ [str "return ",
1266 e',
1267 str "}())"])
1268 in
1269 (e', st)
1270 end handle CantEmbed _ => (e, st))
1271
1272 | ESignalReturn e =>
1273 let
1274 val (e, st) = exp outer (e, st)
1275 in
1276 ((ESignalReturn e, loc), st)
1277 end
1278 | ESignalBind (e1, e2) =>
1279 let
1280 val (e1, st) = exp outer (e1, st)
1281 val (e2, st) = exp outer (e2, st)
1282 in
1283 ((ESignalBind (e1, e2), loc), st)
1284 end
1285 | ESignalSource e =>
1286 let
1287 val (e, st) = exp outer (e, st)
1288 in
1289 ((ESignalSource e, loc), st)
1290 end
1291
1292 | EServerCall (e1, e2, t, ef) =>
1293 let
1294 val (e1, st) = exp outer (e1, st)
1295 val (e2, st) = exp outer (e2, st)
1296 in
1297 ((EServerCall (e1, e2, t, ef), loc), st)
1298 end
1299 | ERecv (e1, e2, t) =>
1300 let
1301 val (e1, st) = exp outer (e1, st)
1302 val (e2, st) = exp outer (e2, st)
1303 in
1304 ((ERecv (e1, e2, t), loc), st)
1305 end
1306 | ESleep (e1, e2) =>
1307 let
1308 val (e1, st) = exp outer (e1, st)
1309 val (e2, st) = exp outer (e2, st)
1310 in
1311 ((ESleep (e1, e2), loc), st)
1312 end)
1313
1314 fun decl (d as (_, loc), st) =
1315 case #1 d of
1316 DVal (x, n, t, e, s) =>
1317 let
1318 val (e, st) = exp [] (e, st)
1319 in
1320 ((DVal (x, n, t, e, s), loc), st)
1321 end
1322 | DValRec vis =>
1323 let
1324 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
1325 let
1326 val (e, st) = exp [] (e, st)
1327 in
1328 ((x, n, t, e, s), st)
1329 end) st vis
1330 in
1331 ((DValRec vis, loc), st)
1332 end
1333 | _ => (d, st)
1143 1334
1144 fun doDecl (d, st) = 1335 fun doDecl (d, st) =
1145 let 1336 let
1146 val (d, st) = decl st d 1337 (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*)
1338 val (d, st) = decl (d, st)
1147 in 1339 in
1148 (List.revAppend (#decls st, [d]), 1340 (List.revAppend (#decls st, [d]),
1149 {decls = [], 1341 {decls = [],
1150 script = #script st, 1342 script = #script st,
1151 included = #included st, 1343 included = #included st,
1161 included = IS.empty, 1353 included = IS.empty,
1162 injectors = IM.empty, 1354 injectors = IM.empty,
1163 listInjectors = TM.empty, 1355 listInjectors = TM.empty,
1164 decoders = IM.empty, 1356 decoders = IM.empty,
1165 maxName = U.File.maxName file + 1} 1357 maxName = U.File.maxName file + 1}
1166 (desourceify file) 1358 file
1167 1359
1168 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) 1360 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
1169 fun lines acc = 1361 fun lines acc =
1170 case TextIO.inputLine inf of 1362 case TextIO.inputLine inf of
1171 NONE => String.concat (rev acc) 1363 NONE => String.concat (rev acc)