Mercurial > urweb

comparison src/jscomp.sml @ 596:d1ec54288b1a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Injected a polymorphic, recursive type
author Adam Chlipala <adamc@hcoop.net>
date Thu, 08 Jan 2009 10:15:45 -0500
parents 02c8ab9f3e8b
children d49d58a69877
comparison
equal deleted inserted replaced
595:02c8ab9f3e8b 596:d1ec54288b1a
147 | [x] => x 147 | [x] => x
148 | x :: es' => (EStrcat (x, strcat loc es'), loc) 148 | x :: es' => (EStrcat (x, strcat loc es'), loc)
149 149
150 fun process file = 150 fun process file =
151 let 151 let
152 val nameds = 152 val (someTs, nameds) =
153 foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) 153 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
154 | ((DValRec vis, _), nameds) => 154 | ((DValRec vis, _), (someTs, nameds)) =>
155 foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) 155 (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
156 nameds vis 156 nameds vis)
157 | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) =>
158 if ElabUtil.classifyDatatype cs = Option then
159 (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t)
160 | (_, someTs) => someTs) someTs cs,
161 nameds)
162 else
163 state
157 | (_, state) => state) 164 | (_, state) => state)
158 IM.empty file 165 (IM.empty, IM.empty) file
159 166
160 fun str loc s = (EPrim (Prim.String s), loc) 167 fun str loc s = (EPrim (Prim.String s), loc)
161 168
162 fun isNullable (t, _) = 169 fun isNullable (t, _) =
163 case t of 170 case t of
248 maxName = n' + 1} 255 maxName = n' + 1}
249 256
250 val (pes, st) = ListUtil.foldlMap 257 val (pes, st) = ListUtil.foldlMap
251 (fn ((_, cn, NONE), st) => 258 (fn ((_, cn, NONE), st) =>
252 (((PCon (dk, PConVar cn, NONE), loc), 259 (((PCon (dk, PConVar cn, NONE), loc),
253 str loc (Int.toString cn)), 260 case dk of
261 Option => str loc "null"
262 | _ => str loc (Int.toString cn)),
254 st) 263 st)
255 | ((_, cn, SOME t), st) => 264 | ((_, cn, SOME t), st) =>
256 let 265 let
257 val (e, st) = quoteExp loc t ((ERel 0, loc), st) 266 val (e, st) = quoteExp loc t ((ERel 0, loc), st)
258 in 267 in
259 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), 268 (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc),
260 e), 269 case dk of
270 Option =>
271 if isNullable t then
272 strcat loc [str loc "{_v:",
273 e,
274 str loc "}"]
275 else
276 e
277 | _ => e),
261 st) 278 st)
262 end) 279 end)
263 st cs 280 st cs
264 281
265 val s = (TFfi ("Basis", "string"), loc) 282 val s = (TFfi ("Basis", "string"), loc)
348 strcat [str ("(d" ^ Int.toString depth ^ "?"), 365 strcat [str ("(d" ^ Int.toString depth ^ "?"),
349 fail, 366 fail,
350 str ":", 367 str ":",
351 succ, 368 succ,
352 str ")"] 369 str ")"]
370 | PCon (Option, _, NONE) =>
371 strcat [str ("(d" ^ Int.toString depth ^ "?"),
372 fail,
373 str ":",
374 succ,
375 str ")"]
376 | PCon (Option, PConVar n, SOME p) =>
377 (case IM.find (someTs, n) of
378 NONE => raise Fail "Jscomp: Not in someTs"
379 | SOME t =>
380 strcat [str ("(d" ^ Int.toString depth ^ "?("
381 ^ (if isNullable t then
382 "d" ^ Int.toString depth ^ "=d"
383 ^ Int.toString depth ^ ".v,"
384 else
385 "")),
386 jsPat depth inner p succ fail,
387 str "):",
388 fail,
389 str ")"])
353 | PCon (_, pc, NONE) => 390 | PCon (_, pc, NONE) =>
354 strcat [str ("(d" ^ Int.toString depth ^ "=="), 391 strcat [str ("(d" ^ Int.toString depth ^ "=="),
355 patCon pc, 392 patCon pc,
356 str "?", 393 str "?",
357 succ, 394 succ,
446 end 483 end
447 in 484 in
448 (str ("_n" ^ Int.toString n), st) 485 (str ("_n" ^ Int.toString n), st)
449 end 486 end
450 487
488 | ECon (Option, _, NONE) => (str "null", st)
489 | ECon (Option, PConVar n, SOME e) =>
490 let
491 val (e, st) = jsE inner (e, st)
492 in
493 case IM.find (someTs, n) of
494 NONE => raise Fail "Jscomp: Not in someTs [2]"
495 | SOME t =>
496 (if isNullable t then
497 strcat [str "{v:",
498 e,
499 str "}"]
500 else
501 e, st)
502 end
503
451 | ECon (_, pc, NONE) => (patCon pc, st) 504 | ECon (_, pc, NONE) => (patCon pc, st)
452 | ECon (_, pc, SOME e) => 505 | ECon (_, pc, SOME e) =>
453 let 506 let
454 val (s, st) = jsE inner (e, st) 507 val (s, st) = jsE inner (e, st)
455 in 508 in
457 patCon pc, 510 patCon pc,
458 str ",v:", 511 str ",v:",
459 s, 512 s,
460 str "}"], st) 513 str "}"], st)
461 end 514 end
515
462 | ENone _ => (str "null", st) 516 | ENone _ => (str "null", st)
463 | ESome (t, e) => 517 | ESome (t, e) =>
464 let 518 let
465 val (e, st) = jsE inner (e, st) 519 val (e, st) = jsE inner (e, st)
466 in 520 in