Mercurial > urweb

comparison src/monoize.sml @ 292:6e665c7c96f6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Error-parsing ints
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 12:15:46 -0400
parents df00701f2323
children 59dc042629b9
comparison
equal deleted inserted replaced
291:550100a44cca 292:6e665c7c96f6
62 case c of 62 case c of
63 L.CName s => s 63 L.CName s => s
64 | _ => poly () 64 | _ => poly ()
65 end 65 end
66 66
67 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
68 (L'.TOption t, loc)), loc)
69 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
70 t), loc)
71 fun readType (t, loc) =
72 (L'.TRecord [("Read", readType' (t, loc)),
73 ("ReadError", readErrType (t, loc))],
74 loc)
75
67 fun monoType env = 76 fun monoType env =
68 let 77 let
69 fun mt env dtmap (all as (c, loc)) = 78 fun mt env dtmap (all as (c, loc)) =
70 let 79 let
71 fun poly () = 80 fun poly () =
84 (L'.TOption (mt env dtmap t), loc) 93 (L'.TOption (mt env dtmap t), loc)
85 94
86 | L.CApp ((L.CFfi ("Basis", "show"), _), t) => 95 | L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
87 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) 96 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
88 | L.CApp ((L.CFfi ("Basis", "read"), _), t) => 97 | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
89 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), 98 readType (mt env dtmap t, loc)
90 (L'.TOption (mt env dtmap t), loc)), loc)
91 99
92 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => 100 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
93 (L'.TFfi ("Basis", "string"), loc) 101 (L'.TFfi ("Basis", "string"), loc)
94 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 102 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
95 (L'.TFfi ("Basis", "string"), loc) 103 (L'.TFfi ("Basis", "string"), loc)
496 | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => 504 | L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
497 let 505 let
498 val t = monoType env t 506 val t = monoType env t
499 val s = (L'.TFfi ("Basis", "string"), loc) 507 val s = (L'.TFfi ("Basis", "string"), loc)
500 in 508 in
501 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc), 509 ((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
502 (L'.ERel 0, loc)), loc), fm) 510 (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
511 end
512 | L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
513 let
514 val t = monoType env t
515 val s = (L'.TFfi ("Basis", "string"), loc)
516 in
517 ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
518 (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
503 end 519 end
504 | L.EFfi ("Basis", "read_int") => 520 | L.EFfi ("Basis", "read_int") =>
505 ((L'.EFfi ("Basis", "stringToInt"), loc), fm) 521 let
522 val t = (L'.TFfi ("Basis", "int"), loc)
523 in
524 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
525 ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
526 loc),
527 fm)
528 end
506 | L.EFfi ("Basis", "read_float") => 529 | L.EFfi ("Basis", "read_float") =>
507 ((L'.EFfi ("Basis", "stringToFloat"), loc), fm) 530 let
531 val t = (L'.TFfi ("Basis", "float"), loc)
532 in
533 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
534 ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
535 loc),
536 fm)
537 end
508 | L.EFfi ("Basis", "read_string") => 538 | L.EFfi ("Basis", "read_string") =>
509 let 539 let
510 val s = (L'.TFfi ("Basis", "string"), loc) 540 val s = (L'.TFfi ("Basis", "string"), loc)
511 in 541 in
512 ((L'.EAbs ("s", s, (L'.TOption s, loc), 542 ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
513 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), fm) 543 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
544 ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
545 fm)
514 end 546 end
515 | L.EFfi ("Basis", "read_bool") => 547 | L.EFfi ("Basis", "read_bool") =>
516 ((L'.EFfi ("Basis", "stringToBool"), loc), fm) 548 let
549 val t = (L'.TFfi ("Basis", "bool"), loc)
550 in
551 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
552 ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
553 loc),
554 fm)
555 end
517 556
518 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => 557 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
519 let 558 let
520 val t = monoType env t 559 val t = monoType env t
521 in 560 in