Mercurial > urweb

comparison src/jscomp.sml @ 970:8371d12ae63f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Hopefully complete refactoring of Jscomp to output ASTs; partial implementation of interpreter in runtime system (demo/alert works)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Sep 2009 12:23:21 -0400
parents 8c37699de273
children e30c2409c9d0
comparison
equal deleted inserted replaced
969:001edfbe2561 970:8371d12ae63f
49 listInjectors : int TM.map, 49 listInjectors : int TM.map,
50 decoders : int IM.map, 50 decoders : int IM.map,
51 maxName : int 51 maxName : int
52 } 52 }
53 53
54 fun varDepth (e, _) =
55 case e of
56 EPrim _ => 0
57 | ERel _ => 0
58 | ENamed _ => 0
59 | ECon (_, _, NONE) => 0
60 | ECon (_, _, SOME e) => varDepth e
61 | ENone _ => 0
62 | ESome (_, e) => varDepth e
63 | EFfi _ => 0
64 | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
65 | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
66 | EAbs _ => 0
67 | EUnop (_, e) => varDepth e
68 | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
69 | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
70 | EField (e, _) => varDepth e
71 | ECase (e, pes, _) =>
72 foldl Int.max (varDepth e)
73 (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
74 | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
75 | EError (e, _) => varDepth e
76 | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2)
77 | EWrite e => varDepth e
78 | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
79 | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
80 | EClosure _ => 0
81 | EQuery _ => 0
82 | EDml _ => 0
83 | ENextval _ => 0
84 | EUnurlify _ => 0
85 | EJavaScript _ => 0
86 | ESignalReturn e => varDepth e
87 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
88 | ESignalSource e => varDepth e
89 | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
90 | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
91 | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
92
93 fun closedUpto d =
94 let
95 fun cu inner (e, _) =
96 case e of
97 EPrim _ => true
98 | ERel n => n < inner orelse n - inner >= d
99 | ENamed _ => true
100 | ECon (_, _, NONE) => true
101 | ECon (_, _, SOME e) => cu inner e
102 | ENone _ => true
103 | ESome (_, e) => cu inner e
104 | EFfi _ => true
105 | EFfiApp (_, _, es) => List.all (cu inner) es
106 | EApp (e1, e2) => cu inner e1 andalso cu inner e2
107 | EAbs (_, _, _, e) => cu (inner + 1) e
108 | EUnop (_, e) => cu inner e
109 | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
110 | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
111 | EField (e, _) => cu inner e
112 | ECase (e, pes, _) =>
113 cu inner e
114 andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
115 | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
116 | EError (e, _) => cu inner e
117 | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2
118 | EWrite e => cu inner e
119 | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
120 | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
121 | EClosure (_, es) => List.all (cu inner) es
122 | EQuery {query, body, initial, ...} =>
123 cu inner query
124 andalso cu (inner + 2) body
125 andalso cu inner initial
126 | EDml e => cu inner e
127 | ENextval e => cu inner e
128 | EUnurlify (e, _) => cu inner e
129 | EJavaScript (_, e) => cu inner e
130 | ESignalReturn e => cu inner e
131 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
132 | ESignalSource e => cu inner e
133 | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
134 | ERecv (e, ek, _) => cu inner e andalso cu inner ek
135 | ESleep (e, ek) => cu inner e andalso cu inner ek
136 in
137 cu 0
138 end
139
140 fun strcat loc es = 54 fun strcat loc es =
141 case es of 55 case es of
142 [] => (EPrim (Prim.String ""), loc) 56 [] => (EPrim (Prim.String ""), loc)
143 | [x] => x 57 | [x] => x
144 | x :: es' => (EStrcat (x, strcat loc es'), loc) 58 | x :: es' => (EStrcat (x, strcat loc es'), loc)
145 59
146 fun patDepth (p, _) =
147 case p of
148 PWild => 0
149 | PVar _ => 0
150 | PPrim _ => 0
151 | PCon (_, _, NONE) => 0
152 | PCon (_, _, SOME p) => 1 + patDepth p
153 | PRecord xpts => foldl Int.max 0 (map (fn (_, p, _) => 1 + patDepth p) xpts)
154 | PNone _ => 0
155 | PSome (_, p) => 1 + patDepth p
156
157 val compact =
158 U.Exp.mapB {typ = fn t => t,
159 exp = fn inner => fn e =>
160 case e of
161 ERel n =>
162 if n >= inner then
163 ERel (n - inner)
164 else
165 e
166 | _ => e,
167 bind = fn (inner, b) =>
168 case b of
169 U.Exp.RelE _ => inner+1
170 | _ => inner}
171
172 exception CantEmbed of typ 60 exception CantEmbed of typ
173 61
174 fun inString {needle, haystack} = 62 fun inString {needle, haystack} = String.isSubstring needle haystack
175 let
176 val (_, suffix) = Substring.position needle (Substring.full haystack)
177 in
178 not (Substring.isEmpty suffix)
179 end
180 63
181 fun process file = 64 fun process file =
182 let 65 let
183 val (someTs, nameds) = 66 val (someTs, nameds) =
184 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) 67 foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
518 401
519 fun jsE inner (e as (_, loc), st) = 402 fun jsE inner (e as (_, loc), st) =
520 let 403 let
521 val str = str loc 404 val str = str loc
522 405
523 fun var n = Int.toString (len + inner - n - 1)
524
525 fun patCon pc = 406 fun patCon pc =
526 case pc of 407 case pc of
527 PConVar n => str (Int.toString n) 408 PConVar n => str (Int.toString n)
528 | PConFfi {mod = "Basis", con = "True", ...} => str "true" 409 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
529 | PConFfi {mod = "Basis", con = "False", ...} => str "false" 410 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
530 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") 411 | PConFfi {con, ...} => str ("\"" ^ con ^ "\"")
531 412
532 fun unsupported s = 413 fun unsupported s =
533 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); 414 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
534 Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e); 415 Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e);
535 (str "ERROR", st)) 416 (str "ERROR", st))
564 str ("\"" ^ String.translate jsChar s ^ "\"") 445 str ("\"" ^ String.translate jsChar s ^ "\"")
565 | Prim.Char ch => str ("'" ^ jsChar ch ^ "'") 446 | Prim.Char ch => str ("'" ^ jsChar ch ^ "'")
566 | _ => str (Prim.toString p) 447 | _ => str (Prim.toString p)
567 end 448 end
568 449
569 fun jsPat depth inner (p, _) succ fail = 450 fun jsPat (p, _) =
570 case p of 451 case p of
571 PWild => succ 452 PWild => str "{c:\"w\"}"
572 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" 453 | PVar _ => str "{c:\"v\"}"
573 ^ Int.toString depth ^ ","), 454 | PPrim p => strcat [str "{c:\"c\",v:",
574 succ,
575 str ")"]
576 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
577 jsPrim p, 455 jsPrim p,
578 str "?", 456 str "}"]
579 succ,
580 str ":",
581 fail,
582 str ")"]
583 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => 457 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
584 strcat [str ("(d" ^ Int.toString depth ^ "?"), 458 str "{c:\"c\",v:true}"
585 succ,
586 str ":",
587 fail,
588 str ")"]
589 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => 459 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
590 strcat [str ("(d" ^ Int.toString depth ^ "?"), 460 str "{c:\"c\",v:false}"
591 fail,
592 str ":",
593 succ,
594 str ")"]
595 | PCon (Option, _, NONE) => 461 | PCon (Option, _, NONE) =>
596 strcat [str ("(d" ^ Int.toString depth ^ "!=null?"), 462 str "{c:\"c\",v:null}"
597 fail,
598 str ":",
599 succ,
600 str ")"]
601 | PCon (Option, PConVar n, SOME p) => 463 | PCon (Option, PConVar n, SOME p) =>
602 (case IM.find (someTs, n) of 464 (case IM.find (someTs, n) of
603 NONE => raise Fail "Jscomp: Not in someTs" 465 NONE => raise Fail "Jscomp: Not in someTs"
604 | SOME t => 466 | SOME t => strcat [str ("{c:\"s\",n:"
605 strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" 467 ^ (if isNullable t then
606 ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth 468 "true"
607 ^ (if isNullable t then 469 else
608 ".v," 470 "false")
609 else 471 ^ ",p:"),
610 "") 472 jsPat p,
611 ^ ","), 473 str "}"])
612 jsPat (depth+1) inner p succ fail, 474 | PCon (_, pc, NONE) => strcat [str "{c:\"0\",n:",
613 str "):", 475 patCon pc,
614 fail, 476 str "}"]
615 str ")"]) 477 | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
616 | PCon (_, pc, NONE) => 478 patCon pc,
617 strcat [str ("(d" ^ Int.toString depth ^ "=="), 479 str ",p:",
618 patCon pc, 480 jsPat p,
619 str "?", 481 str "}"]
620 succ, 482 | PRecord xps => strcat [str "{c:\"r\",l:",
621 str ":", 483 foldr (fn ((x, p, _), e) =>
622 fail, 484 strcat [str ("cons({n:\"" ^ x ^ "\",p:"),
623 str ")"] 485 jsPat p,
624 | PCon (_, pc, SOME p) => 486 str "},",
625 strcat [str ("(d" ^ Int.toString depth ^ ".n=="), 487 e,
626 patCon pc, 488 str ")"])
627 str ("?(d" ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth ^ ".v,"), 489 (str "null") xps,
628 jsPat (depth+1) inner p succ fail, 490 str "}"]
629 str "):", 491 | PNone _ => str "{c:\"c\",v:null}"
630 fail, 492 | PSome (t, p) => strcat [str ("{c:\"s\",n:"
631 str ")"]
632 | PRecord xps =>
633 let
634 val (_, succ) = foldl
635 (fn ((x, p, _), (inner, succ)) =>
636 (inner + E.patBindsN p,
637 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
638 ^ Int.toString depth ^ "._" ^ x ^ ","),
639 jsPat (depth+1) inner p succ fail,
640 str ")"]))
641 (inner, succ) xps
642 in
643 succ
644 end
645 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "!=null?"),
646 fail,
647 str ":",
648 succ,
649 str ")"]
650 | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" ^ Int.toString (depth+1)
651 ^ "=d" ^ Int.toString depth
652 ^ (if isNullable t then 493 ^ (if isNullable t then
653 ".v" 494 "true"
654 else 495 else
655 "") 496 "false")
656 ^ ","), 497 ^ ",p:"),
657 jsPat (depth+1) inner p succ fail, 498 jsPat p,
658 str "):", 499 str "}"]
659 fail,
660 str ")"]
661 500
662 val jsifyString = String.translate (fn #"\"" => "\\\"" 501 val jsifyString = String.translate (fn #"\"" => "\\\""
663 | #"\\" => "\\\\" 502 | #"\\" => "\\\\"
664 | ch => String.str ch) 503 | ch => String.str ch)
665 504
675 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" 514 | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
676 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; 515 | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
677 raise Fail "Jscomp: deStrcat") 516 raise Fail "Jscomp: deStrcat")
678 517
679 val quoteExp = quoteExp loc 518 val quoteExp = quoteExp loc
680
681 val hasQuery = U.Exp.exists {typ = fn _ => false,
682 exp = fn EQuery _ => true
683 | _ => false}
684
685 val indirectQuery = U.Exp.exists {typ = fn _ => false,
686 exp = fn ENamed n =>
687 (case IM.find (nameds, n) of
688 NONE => false
689 | SOME e => hasQuery e)
690 | _ => false}
691
692 in 519 in
693 (*if indirectQuery e then
694 Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e)
695 else
696 ();*)
697
698 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), 520 (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
699 ("inner", Print.PD.string (Int.toString inner))];*) 521 ("inner", Print.PD.string (Int.toString inner))];*)
700 522
701 case #1 e of 523 case #1 e of
702 EPrim p => (jsPrim p, st) 524 EPrim p => (strcat [str "{c:\"c\",v:",
525 jsPrim p,
526 str "}"],
527 st)
703 | ERel n => 528 | ERel n =>
704 if n < inner then 529 if n < inner then
705 (str ("_" ^ var n), st) 530 (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st)
706 else 531 else
707 let 532 let
708 val n = n - inner 533 val n = n - inner
709 (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty 534 (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty
710 (List.nth (outer, n)))]*) 535 (List.nth (outer, n)))]*)
536 val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
711 in 537 in
712 quoteExp (List.nth (outer, n)) ((ERel n, loc), st) 538 (strcat [str "{c:\"c\",v:",
539 e,
540 str "}"], st)
713 end 541 end
714 542
715 | ENamed n => 543 | ENamed n =>
716 let 544 let
717 val st = 545 val st =
729 listInjectors = #listInjectors st, 557 listInjectors = #listInjectors st,
730 decoders = #decoders st, 558 decoders = #decoders st,
731 maxName = #maxName st} 559 maxName = #maxName st}
732 560
733 val old = e 561 val old = e
734 val (e, st) = jsExp mode [] 0 (e, st) 562 val (e, st) = jsExp mode [] (e, st)
735 val new = e 563 val new = e
736 val e = deStrcat 0 e 564 val e = deStrcat 0 e
737 565
738 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" 566 val sc = "urfuncs[" ^ Int.toString n ^ "] = " ^ e ^ ";\n"
739 in 567 in
740 (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old), 568 (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
741 ("new", MonoPrint.p_exp MonoEnv.empty new)];*) 569 ("new", MonoPrint.p_exp MonoEnv.empty new)];*)
742 {decls = #decls st, 570 {decls = #decls st,
743 script = sc :: #script st, 571 script = sc :: #script st,
746 listInjectors = #listInjectors st, 574 listInjectors = #listInjectors st,
747 decoders= #decoders st, 575 decoders= #decoders st,
748 maxName = #maxName st} 576 maxName = #maxName st}
749 end 577 end
750 in 578 in
751 (str ("_n" ^ Int.toString n), st) 579 (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st)
752 end 580 end
753 581
754 | ECon (Option, _, NONE) => (str "null", st) 582 | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st)
755 | ECon (Option, PConVar n, SOME e) => 583 | ECon (Option, PConVar n, SOME e) =>
756 let 584 let
757 val (e, st) = jsE inner (e, st) 585 val (e, st) = jsE inner (e, st)
758 in 586 in
759 case IM.find (someTs, n) of 587 case IM.find (someTs, n) of
760 NONE => raise Fail "Jscomp: Not in someTs [2]" 588 NONE => raise Fail "Jscomp: Not in someTs [2]"
761 | SOME t => 589 | SOME t =>
762 (if isNullable t then 590 (if isNullable t then
763 strcat [str "{v:", 591 strcat [str "{c:\"s\",v:",
764 e, 592 e,
765 str "}"] 593 str "}"]
766 else 594 else
767 e, st) 595 e, st)
768 end 596 end
769 597
770 | ECon (_, pc, NONE) => (patCon pc, st) 598 | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:",
599 patCon pc,
600 str "}"],
601 st)
771 | ECon (_, pc, SOME e) => 602 | ECon (_, pc, SOME e) =>
772 let 603 let
773 val (s, st) = jsE inner (e, st) 604 val (s, st) = jsE inner (e, st)
774 in 605 in
775 (strcat [str "{n:", 606 (strcat [str "{c:\"1\",n:",
776 patCon pc, 607 patCon pc,
777 str ",v:", 608 str ",v:",
778 s, 609 s,
779 str "}"], st) 610 str "}"], st)
780 end 611 end
781 612
782 | ENone _ => (str "null", st) 613 | ENone _ => (str "{c:\"c\",v:null}", st)
783 | ESome (t, e) => 614 | ESome (t, e) =>
784 let 615 let
785 val (e, st) = jsE inner (e, st) 616 val (e, st) = jsE inner (e, st)
786 in 617 in
787 (if isNullable t then 618 (if isNullable t then
788 strcat [str "{v:", e, str "}"] 619 strcat [str "{c:\"s\",v:", e, str "}"]
789 else 620 else
790 e, st) 621 e, st)
791 end 622 end
792 623
793 | EFfi k => 624 | EFfi k =>
796 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k 627 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
797 ^ " in JavaScript"); 628 ^ " in JavaScript");
798 "ERROR") 629 "ERROR")
799 | SOME s => s 630 | SOME s => s
800 in 631 in
801 (str name, st) 632 (str ("{c:\"c\",v:" ^ name ^ "}"), st)
802 end 633 end
803 | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "\"", 634 | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"",
804 e, 635 e,
805 str "\""], st) 636 str "\"}"], st)
806 | EFfiApp ("Basis", "kc", []) => (str "kc(event)", st)
807 | EFfiApp (m, x, args) => 637 | EFfiApp (m, x, args) =>
808 let 638 let
809 val name = case Settings.jsFunc (m, x) of 639 val name = case Settings.jsFunc (m, x) of
810 NONE => (EM.errorAt loc ("Unsupported FFI function " 640 NONE => (EM.errorAt loc ("Unsupported FFI function "
811 ^ x ^ " in JavaScript"); 641 ^ x ^ " in JavaScript");
812 "ERROR") 642 "ERROR")
813 | SOME s => s 643 | SOME s => s
814 in 644
815 case args of 645 val (e, st) = foldr (fn (e, (acc, st)) =>
816 [] => (str (name ^ "()"), st) 646 let
817 | [e] => 647 val (e, st) = jsE inner (e, st)
818 let 648 in
819 val (e, st) = jsE inner (e, st) 649 (strcat [str "cons(",
820 in 650 e,
821 (strcat [str (name ^ "("), 651 str ",",
822 e, 652 acc,
823 str ")"], st) 653 str ")"],
824 end 654 st)
825 | e :: es => 655 end)
826 let 656 (str "null", st) args
827 val (e, st) = jsE inner (e, st) 657 in
828 val (es, st) = ListUtil.foldlMapConcat 658 (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"),
829 (fn (e, st) => 659 e,
830 let 660 str "}"],
831 val (e, st) = jsE inner (e, st) 661 st)
832 in
833 ([str ",", e], st)
834 end)
835 st es
836 in
837 (strcat (str (name ^ "(")
838 :: e
839 :: es
840 @ [str ")"]), st)
841 end
842 end 662 end
843 663
844 | EApp (e1, e2) => 664 | EApp (e1, e2) =>
845 let 665 let
846 val (e1, st) = jsE inner (e1, st) 666 val (e1, st) = jsE inner (e1, st)
847 val (e2, st) = jsE inner (e2, st) 667 val (e2, st) = jsE inner (e2, st)
848 in 668 in
849 (strcat [e1, str "(", e2, str ")"], st) 669 (strcat [str "{c:\"a\",f:",
670 e1,
671 str ",x:",
672 e2,
673 str "}"], st)
850 end 674 end
851 | EAbs (_, _, _, e) => 675 | EAbs (_, _, _, e) =>
852 let 676 let
853 val locals = List.tabulate
854 (varDepth e,
855 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
856 val (e, st) = jsE (inner + 1) (e, st) 677 val (e, st) = jsE (inner + 1) (e, st)
857 in 678 in
858 (strcat (str ("function(_" 679 (strcat [str "{c:\"l\",b:",
859 ^ Int.toString (len + inner) 680 e,
860 ^ "){") 681 str "}"], st)
861 :: locals 682 end
862 @ [str "return ", 683
863 e, 684 | EUnop (s, e) =>
864 str "}"]), 685 let
686 val name = case s of
687 "!" => "not"
688 | "-" => "neg"
689 | _ => raise Fail "Jscomp: Unknown unary operator"
690
691 val (e, st) = jsE inner (e, st)
692 in
693 (strcat [str ("{c:\"f\",f:" ^ name ^ ",:a:cons("),
694 e,
695 str ",null)}"],
865 st) 696 st)
866 end 697 end
867 698 | EBinop (s, e1, e2) =>
868 | EUnop (s, e) => 699 let
869 let 700 val name = case s of
870 val (e, st) = jsE inner (e, st) 701 "==" => "eq"
871 in 702 | "!strcmp" => "eq"
872 (strcat [str ("(" ^ s), 703 | "+" => "plus"
873 e, 704 | "-" => "minus"
874 str ")"], 705 | "*" => "times"
875 st) 706 | "/" => "div"
876 end 707 | "%" => "mod"
877 | EBinop ("strcmp", e1, e2) => 708 | "<" => "lt"
878 let 709 | "<=" => "le"
710 | _ => raise Fail "Jscomp: Unknown binary operator"
711
879 val (e1, st) = jsE inner (e1, st) 712 val (e1, st) = jsE inner (e1, st)
880 val (e2, st) = jsE inner (e2, st) 713 val (e2, st) = jsE inner (e2, st)
881 in 714 in
882 (strcat [str "strcmp(", 715 (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("),
883 e1, 716 e1,
884 str ",", 717 str ",cons(",
885 e2, 718 e2,
886 str ")"], 719 str ",null))}"],
887 st) 720 st)
888 end 721 end
889 | EBinop (s, e1, e2) => 722
890 let 723 | ERecord [] => (str "{c:\"c\",v:null}", st)
891 val s = 724 | ERecord xes =>
892 case s of 725 let
893 "!strcmp" => "=="
894 | _ => s
895
896 val (e1, st) = jsE inner (e1, st)
897 val (e2, st) = jsE inner (e2, st)
898 in
899 (strcat [str "(",
900 e1,
901 str s,
902 e2,
903 str ")"],
904 st)
905 end
906
907 | ERecord [] => (str "null", st)
908 | ERecord [(x, e, _)] =>
909 let
910 val (e, st) = jsE inner (e, st)
911 in
912 (strcat [str ("{_" ^ x ^ ":"), e, str "}"], st)
913 end
914 | ERecord ((x, e, _) :: xes) =>
915 let
916 val (e, st) = jsE inner (e, st)
917
918 val (es, st) = 726 val (es, st) =
919 foldr (fn ((x, e, _), (es, st)) => 727 foldr (fn ((x, e, _), (es, st)) =>
920 let 728 let
921 val (e, st) = jsE inner (e, st) 729 val (e, st) = jsE inner (e, st)
922 in 730 in
923 (str (",_" ^ x ^ ":") 731 (strcat [str ("cons({n:\"" ^ x ^ ",v:"),
924 :: e 732 e,
925 :: es, 733 str "},",
734 es,
735 str ")"],
926 st) 736 st)
927 end) 737 end)
928 ([str "}"], st) xes 738 (str "null", st) xes
929 in 739 in
930 (strcat (str ("{_" ^ x ^ ":") 740 (strcat [str "{c:\"r\",l:",
931 :: e 741 es,
932 :: es), 742 str "}"],
933 st) 743 st)
934 end 744 end
935 | EField (e', x) => 745 | EField (e', x) =>
936 let 746 let
937 fun default () = 747 fun default () =
938 let 748 let
939 val (e', st) = jsE inner (e', st) 749 val (e', st) = jsE inner (e', st)
940 in 750 in
941 (strcat [e', 751 (strcat [str "{c:\".\",r:",
942 str ("._" ^ x)], st) 752 e',
753 str (",f:\"" ^ x ^ "\"}")], st)
943 end 754 end
944 755
945 fun seek (e, xs) = 756 fun seek (e, xs) =
946 case #1 e of 757 case #1 e of
947 ERel n => 758 ERel n =>
958 | _ => raise Fail "Jscomp: Bad seek [2]") 769 | _ => raise Fail "Jscomp: Bad seek [2]")
959 t xs 770 t xs
960 771
961 val e = (ERel n, loc) 772 val e = (ERel n, loc)
962 val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs 773 val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
774 val (e, st) = quoteExp t (e, st)
963 in 775 in
964 quoteExp t (e, st) 776 (strcat [str "{c:\"c\",v:",
777 e,
778 str "}"],
779 st)
965 end 780 end
966 | EField (e', x) => seek (e', x :: xs) 781 | EField (e', x) => seek (e', x :: xs)
967 | _ => default () 782 | _ => default ()
968 in 783 in
969 seek (e', [x]) 784 seek (e', [x])
970 end 785 end
971 786
972 | ECase (e', pes, {result, ...}) => 787 | ECase (e', pes, _) =>
973 let 788 let
974 val plen = length pes 789 val (e', st) = jsE inner (e', st)
975 790
976 val (cases, st) = ListUtil.foldliMap 791 val (ps, st) =
977 (fn (i, (p, e), st) => 792 foldr (fn ((p, e), (ps, st)) =>
978 let 793 let
979 val (e, st) = jsE (inner + E.patBindsN p) (e, st) 794 val (e, st) = jsE inner (e, st)
980 val fail = 795 in
981 if i = plen - 1 then 796 (strcat [str "cons({p:",
982 str ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")") 797 jsPat p,
983 else 798 str ",b:",
984 str ("c" ^ Int.toString (i+1) ^ "()") 799 e,
985 val c = jsPat 0 inner p e fail 800 str "},",
986 in 801 ps,
987 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), 802 str ")"],
988 c, 803 st)
989 str "},"], 804 end)
990 st) 805 (str "null", st) pes
991 end) 806 in
992 st pes 807 (strcat [str "{c:\"m\",e:",
993 808 e,
994 val depth = foldl Int.max 0 (map (fn (p, _) => 1 + patDepth p) pes) 809 str ",p:",
995 val normalDepth = foldl Int.max 0 (map (fn (_, e) => 1 + varDepth e) pes) 810 ps,
996 val (e, st) = jsE inner (e', st) 811 str "}"], st)
997
998 val len = inner + len
999 val normalVars = List.tabulate (normalDepth, fn n => "_" ^ Int.toString (n + len))
1000 val patVars = List.tabulate (depth, fn n => "d" ^ Int.toString n)
1001 val caseVars = ListUtil.mapi (fn (i, _) => "c" ^ Int.toString i) pes
1002 in
1003 (strcat (str "(function (){ var "
1004 :: str (String.concatWith "," (normalVars @ patVars @ caseVars) ^ ";d0=")
1005 :: e
1006 :: str ";\nreturn ("
1007 :: List.revAppend (cases,
1008 [str "c0()) } ())"])), st)
1009 end 812 end
1010 813
1011 | EStrcat (e1, e2) => 814 | EStrcat (e1, e2) =>
1012 let 815 let
1013 val (e1, st) = jsE inner (e1, st) 816 val (e1, st) = jsE inner (e1, st)
1014 val (e2, st) = jsE inner (e2, st) 817 val (e2, st) = jsE inner (e2, st)
1015 in 818 in
1016 (strcat [str "cat(", e1, str ",", e2, str ")"], st) 819 (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
1017 end 820 end
1018 821
1019 | EError (e, _) => 822 | EError (e, _) =>
1020 let 823 let
1021 val (e, st) = jsE inner (e, st) 824 val (e, st) = jsE inner (e, st)
1022 in 825 in
1023 (strcat [str "er(", e, str ")"], 826 (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"],
1024 st) 827 st)
1025 end
1026
1027 | EWrite e =>
1028 let
1029 val (e, st) = jsE inner (e, st)
1030 in
1031 (strcat [str "document.write(",
1032 e,
1033 str ".v)"], st)
1034 end 828 end
1035 829
1036 | ESeq (e1, e2) => 830 | ESeq (e1, e2) =>
1037 let 831 let
1038 val (e1, st) = jsE inner (e1, st) 832 val (e1, st) = jsE inner (e1, st)
1039 val (e2, st) = jsE inner (e2, st) 833 val (e2, st) = jsE inner (e2, st)
1040 in 834 in
1041 (strcat [str "(", e1, str ",", e2, str ")"], st) 835 (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
1042 end 836 end
1043 | ELet (_, _, e1, e2) => 837 | ELet (_, _, e1, e2) =>
1044 let 838 let
1045 val (e1, st) = jsE inner (e1, st) 839 val (e1, st) = jsE inner (e1, st)
1046 val (e2, st) = jsE (inner + 1) (e2, st) 840 val (e2, st) = jsE (inner + 1) (e2, st)
1047 in 841 in
1048 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), 842 (strcat [str "{c:\"=\",e1:",
1049 e1, 843 e1,
1050 str ",", 844 str ",e2:",
1051 e2, 845 e2,
1052 str ")"], st) 846 str "}"], st)
1053 end 847 end
1054 848
1055 | EJavaScript (Source _, e) => 849 | EJavaScript (Source _, e) =>
1056 (foundJavaScript := true; 850 (foundJavaScript := true;
1057 jsE inner (e, st)) 851 jsE inner (e, st))
1058 | EJavaScript (_, e) => 852 | EJavaScript (_, e) =>
1059 let 853 let
1060 val locals = List.tabulate
1061 (varDepth e,
1062 fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";"))
1063
1064 val (e, st) = jsE inner (e, st) 854 val (e, st) = jsE inner (e, st)
1065 in 855 in
1066 foundJavaScript := true; 856 foundJavaScript := true;
1067 (strcat (str "cs(function(){" 857 (strcat [str "{c:\"e\",e:",
1068 :: locals 858 e,
1069 @ [str "return ", 859 str "}"],
1070 (*compact inner*) e,
1071 str "})"]),
1072 st) 860 st)
1073 end 861 end
1074 862
863 | EWrite _ => unsupported "EWrite"
1075 | EClosure _ => unsupported "EClosure" 864 | EClosure _ => unsupported "EClosure"
1076 | EQuery _ => unsupported "Query" 865 | EQuery _ => unsupported "Query"
1077 | EDml _ => unsupported "DML" 866 | EDml _ => unsupported "DML"
1078 | ENextval _ => unsupported "Nextval" 867 | ENextval _ => unsupported "Nextval"
1079 | EUnurlify _ => unsupported "EUnurlify" 868 | EUnurlify _ => unsupported "EUnurlify"
1081 870
1082 | ESignalReturn e => 871 | ESignalReturn e =>
1083 let 872 let
1084 val (e, st) = jsE inner (e, st) 873 val (e, st) = jsE inner (e, st)
1085 in 874 in
1086 (strcat [str "sr(", 875 (strcat [str "{c:\"f\",f:sr,a:cons(",
1087 e, 876 e,
1088 str ")"], 877 str ",null)}"],
1089 st) 878 st)
1090 end 879 end
1091 | ESignalBind (e1, e2) => 880 | ESignalBind (e1, e2) =>
1092 let 881 let
1093 val (e1, st) = jsE inner (e1, st) 882 val (e1, st) = jsE inner (e1, st)
1094 val (e2, st) = jsE inner (e2, st) 883 val (e2, st) = jsE inner (e2, st)
1095 in 884 in
1096 (strcat [str "sb(", 885 (strcat [str "{c:\"b\",e1:",
1097 e1, 886 e1,
1098 str ",", 887 str ",e2:",
1099 e2, 888 e2,
1100 str ")"], 889 str "}"],
1101 st) 890 st)
1102 end 891 end
1103 | ESignalSource e => 892 | ESignalSource e =>
1104 let 893 let
1105 val (e, st) = jsE inner (e, st) 894 val (e, st) = jsE inner (e, st)
1106 in 895 in
1107 (strcat [str "ss(", 896 (strcat [str "{c:\"f\",f:ss,a:cons(",
1108 e, 897 e,
1109 str ")"], 898 str ",null)}"],
1110 st) 899 st)
1111 end 900 end
1112 901
1113 | EServerCall (e, ek, t, eff) => 902 | EServerCall (e, ek, t, eff) =>
1114 let 903 let
1115 val (e, st) = jsE inner (e, st) 904 val (e, st) = jsE inner (e, st)
1116 val (ek, st) = jsE inner (ek, st) 905 val (ek, st) = jsE inner (ek, st)
1117 val (unurl, st) = unurlifyExp loc (t, st) 906 val (unurl, st) = unurlifyExp loc (t, st)
1118 in 907 in
1119 (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","), 908 (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\""
909 ^ Settings.getUrlPrefix ()
910 ^ "\"},cons("),
1120 e, 911 e,
1121 str ("), function(s){var t=s.split(\"/\");var i=0;return " 912 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
1122 ^ unurl ^ "},"), 913 ^ unurl ^ "}},cons({c:\"!\",e:"),
1123 ek, 914 ek,
1124 str ("," 915 str ("},cons("
1125 ^ (case eff of 916 ^ (case eff of
1126 ReadCookieWrite => "true" 917 ReadCookieWrite => "true"
1127 | _ => "false") 918 | _ => "false")
1128 ^ ")")], 919 ^ ",null)))))}")],
1129 st) 920 st)
1130 end 921 end
1131 922
1132 | ERecv (e, ek, t) => 923 | ERecv (e, ek, t) =>
1133 let 924 let
1134 val (e, st) = jsE inner (e, st) 925 val (e, st) = jsE inner (e, st)
1135 val (ek, st) = jsE inner (ek, st) 926 val (ek, st) = jsE inner (ek, st)
1136 val (unurl, st) = unurlifyExp loc (t, st) 927 val (unurl, st) = unurlifyExp loc (t, st)
1137 in 928 in
1138 (strcat [str "rv(", 929 (strcat [str ("{c:\"f\",f:rv,a:cons("),
1139 e, 930 e,
1140 str (", function(s){var t=s.split(\"/\");var i=0;return " 931 str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
1141 ^ unurl ^ "},"), 932 ^ unurl ^ "}},cons({c:\"!\",e:"),
1142 ek, 933 ek,
1143 str ")"], 934 str ("},null)))}")],
1144 st) 935 st)
1145 end 936 end
1146 937
1147 | ESleep (e, ek) => 938 | ESleep (e, ek) =>
1148 let 939 let
1149 val (e, st) = jsE inner (e, st) 940 val (e, st) = jsE inner (e, st)
1150 val (ek, st) = jsE inner (ek, st) 941 val (ek, st) = jsE inner (ek, st)
1151 in 942 in
1152 (strcat [str "window.setTimeout(", 943 (strcat [str "{c:\"f\",f:window.setTimeout,a:cons(",
1153 ek, 944 ek,
1154 str ", ", 945 str ",cons(",
1155 e, 946 e,
1156 str ")"], 947 str ",null))}"],
1157 st) 948 st)
1158 end 949 end
1159 end 950 end
1160 in 951 in
1161 jsE 952 jsE 0
1162 end 953 end
1163
1164 954
1165 fun patBinds ((p, _), env) = 955 fun patBinds ((p, _), env) =
1166 case p of 956 case p of
1167 PWild => env 957 PWild => env
1168 | PVar (_, t) => t :: env 958 | PVar (_, t) => t :: env
1348 in 1138 in
1349 ((EUnurlify (e, t), loc), st) 1139 ((EUnurlify (e, t), loc), st)
1350 end 1140 end
1351 1141
1352 | EJavaScript (m, e') => 1142 | EJavaScript (m, e') =>
1353 (let 1143 (foundJavaScript := true;
1354 val len = length outer 1144 jsExp m outer (e', st)
1355 fun str s = (EPrim (Prim.String s), #2 e') 1145 handle CantEmbed _ => (e, st))
1356
1357 val locals = List.tabulate
1358 (varDepth e',
1359 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
1360
1361 val (e', st) = jsExp m outer 0 (e', st)
1362
1363 val e' =
1364 case locals of
1365 [] => e'
1366 | _ =>
1367 strcat (#2 e') (str "(function(){"
1368 :: locals
1369 @ [str "return ",
1370 e',
1371 str "}())"])
1372 in
1373 (e', st)
1374 end handle CantEmbed _ => (e, st))
1375 1146
1376 | ESignalReturn e => 1147 | ESignalReturn e =>
1377 let 1148 let
1378 val (e, st) = exp outer (e, st) 1149 val (e, st) = exp outer (e, st)
1379 in 1150 in