Mercurial > urweb

comparison src/monoize.sml @ 1065:217eb87dde31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.url and redirects
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Dec 2009 13:32:09 -0500
parents 93315ac00394
children 50dd937c4cb9
comparison
equal deleted inserted replaced
1064:b89e3d8731ed 1065:217eb87dde31
392 fun capitalize s = 392 fun capitalize s =
393 if s = "" then 393 if s = "" then
394 s 394 s
395 else 395 else
396 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 396 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
397
398 val inTag = ref false
397 399
398 fun fooifyExp fk env = 400 fun fooifyExp fk env =
399 let 401 let
400 fun fooify fm (e, tAll as (t, loc)) = 402 fun fooify fm (e, tAll as (t, loc)) =
401 case #1 e of 403 case #1 e of
1058 | L.EFfi ("Basis", "show_int") => 1060 | L.EFfi ("Basis", "show_int") =>
1059 ((L'.EFfi ("Basis", "intToString"), loc), fm) 1061 ((L'.EFfi ("Basis", "intToString"), loc), fm)
1060 | L.EFfi ("Basis", "show_float") => 1062 | L.EFfi ("Basis", "show_float") =>
1061 ((L'.EFfi ("Basis", "floatToString"), loc), fm) 1063 ((L'.EFfi ("Basis", "floatToString"), loc), fm)
1062 | L.EFfi ("Basis", "show_string") => 1064 | L.EFfi ("Basis", "show_string") =>
1065 let
1066 val s = (L'.TFfi ("Basis", "string"), loc)
1067 in
1068 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
1069 end
1070 | L.EFfi ("Basis", "show_url") =>
1063 let 1071 let
1064 val s = (L'.TFfi ("Basis", "string"), loc) 1072 val s = (L'.TFfi ("Basis", "string"), loc)
1065 in 1073 in
1066 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) 1074 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
1067 end 1075 end
2470 class), _), 2478 class), _),
2471 attrs), _), 2479 attrs), _),
2472 tag), _), 2480 tag), _),
2473 xml) => 2481 xml) =>
2474 let 2482 let
2483 val inT = !inTag
2484 val () = inTag := true
2485
2475 fun getTag' (e, _) = 2486 fun getTag' (e, _) =
2476 case e of 2487 case e of
2477 L.EFfi ("Basis", tag) => (tag, []) 2488 L.EFfi ("Basis", tag) => (tag, [])
2478 | L.ECApp (e, t) => let 2489 | L.ECApp (e, t) => let
2479 val (tag, ts) = getTag' e 2490 val (tag, ts) = getTag' e
2705 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), 2716 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
2706 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), 2717 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
2707 (L'.EPrim (Prim.String ")"), loc)), loc)), loc) 2718 (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
2708 end 2719 end
2709 in 2720 in
2710 case tag of 2721 (case tag of
2711 "body" => let 2722 "body" => let
2712 val onload = execify onload 2723 val onload = execify onload
2713 val onunload = execify onunload 2724 val onunload = execify onunload
2714 in 2725 in
2715 normal ("body", 2726 normal ("body",
2716 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", 2727 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
2717 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", 2728 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
2718 [(L'.ERecord [], loc)]), loc), 2729 [(L'.ERecord [], loc)]), loc),
2719 onload), loc)]), 2730 onload), loc)]),
2720 loc), 2731 loc),
2721 (L'.EFfiApp ("Basis", "maybe_onunload", 2732 (L'.EFfiApp ("Basis", "maybe_onunload",
2722 [onunload]), 2733 [onunload]),
2723 loc)), loc), 2734 loc)), loc),
2724 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) 2735 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
2725 end 2736 end
2726 2737
2727 | "dyn" => 2738 | "dyn" =>
2728 let 2739 let
2729 fun inTag tag = case targs of 2740 fun inTag tag = case targs of
2730 (L.CRecord (_, ctx), _) :: _ => 2741 (L.CRecord (_, ctx), _) :: _ =>
2731 List.exists (fn ((L.CName tag', _), _) => tag' = tag 2742 List.exists (fn ((L.CName tag', _), _) => tag' = tag
2732 | _ => false) ctx 2743 | _ => false) ctx
2733 | _ => false 2744 | _ => false
2734 2745
2735 val tag = if inTag "Tr" then 2746 val tag = if inTag "Tr" then
2736 "tr" 2747 "tr"
2737 else if inTag "Table" then 2748 else if inTag "Table" then
2738 "table" 2749 "table"
2739 else 2750 else
2740 "span" 2751 "span"
2741 in 2752 in
2742 case attrs of 2753 case attrs of
2743 [("Signal", e, _)] => 2754 [("Signal", e, _)] =>
2744 ((L'.EStrcat 2755 ((L'.EStrcat
2745 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" 2756 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
2746 ^ tag ^ "\", execD(")), loc), 2757 ^ tag ^ "\", execD(")), loc),
2747 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 2758 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
2748 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 2759 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
2749 fm)
2750 | _ => raise Fail "Monoize: Bad dyn attributes"
2751 end
2752
2753 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
2754 | "button" => normal ("input type=\"submit\"", NONE, NONE)
2755 | "hidden" => input "hidden"
2756
2757 | "textbox" =>
2758 (case targs of
2759 [_, (L.CName name, _)] =>
2760 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
2761 NONE =>
2762 let
2763 val (ts, fm) = tagStart "input"
2764 in
2765 ((L'.EStrcat (ts,
2766 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
2767 loc)), loc), fm)
2768 end
2769 | SOME (_, src, _) =>
2770 (strcat [str "<script type=\"text/javascript\">inp(exec(",
2771 (L'.EJavaScript (L'.Script, src), loc),
2772 str "))</script>"],
2773 fm))
2774 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2775 raise Fail "No name passed to textbox tag"))
2776 | "password" => input "password"
2777 | "textarea" =>
2778 (case targs of
2779 [_, (L.CName name, _)] =>
2780 let
2781 val (ts, fm) = tagStart "textarea"
2782 val (xml, fm) = monoExp (env, st, fm) xml
2783 in
2784 ((L'.EStrcat ((L'.EStrcat (ts,
2785 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
2786 (L'.EStrcat (xml,
2787 (L'.EPrim (Prim.String "</textarea>"),
2788 loc)), loc)),
2789 loc), fm)
2790 end
2791 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2792 raise Fail "No name passed to ltextarea tag"))
2793
2794 | "checkbox" => input "checkbox"
2795 | "upload" => input "file"
2796
2797 | "radio" =>
2798 (case targs of
2799 [_, (L.CName name, _)] =>
2800 monoExp (env, St.setRadioGroup (st, name), fm) xml
2801 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2802 raise Fail "No name passed to radio tag"))
2803 | "radioOption" =>
2804 (case St.radioGroup st of
2805 NONE => raise Fail "No name for radioGroup"
2806 | SOME name =>
2807 normal ("input",
2808 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
2809 NONE))
2810
2811 | "select" =>
2812 (case targs of
2813 [_, (L.CName name, _)] =>
2814 let
2815 val (ts, fm) = tagStart "select"
2816 val (xml, fm) = monoExp (env, st, fm) xml
2817 in
2818 ((L'.EStrcat ((L'.EStrcat (ts,
2819 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
2820 loc)), loc),
2821 (L'.EStrcat (xml,
2822 (L'.EPrim (Prim.String "</select>"),
2823 loc)), loc)),
2824 loc),
2825 fm) 2760 fm)
2826 end 2761 | _ => raise Fail "Monoize: Bad dyn attributes"
2827 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 2762 end
2828 raise Fail "No name passed to lselect tag")) 2763
2829 2764 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
2830 | "ctextbox" => 2765 | "button" => normal ("input type=\"submit\"", NONE, NONE)
2831 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 2766 | "hidden" => input "hidden"
2832 NONE => 2767
2833 let 2768 | "textbox" =>
2834 val (ts, fm) = tagStart "input" 2769 (case targs of
2835 in 2770 [_, (L.CName name, _)] =>
2836 ((L'.EStrcat (ts, 2771 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
2837 (L'.EPrim (Prim.String " />"), loc)), 2772 NONE =>
2838 loc), fm) 2773 let
2839 end 2774 val (ts, fm) = tagStart "input"
2840 | SOME (_, src, _) => 2775 in
2841 let 2776 ((L'.EStrcat (ts,
2842 val sc = strcat [str "inp(exec(", 2777 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
2843 (L'.EJavaScript (L'.Script, src), loc), 2778 loc)), loc), fm)
2844 str "))"] 2779 end
2845 val sc = setAttrs sc 2780 | SOME (_, src, _) =>
2846 in 2781 (strcat [str "<script type=\"text/javascript\">inp(exec(",
2847 (strcat [str "<script type=\"text/javascript\">", 2782 (L'.EJavaScript (L'.Script, src), loc),
2848 sc, 2783 str "))</script>"],
2849 str "</script>"], 2784 fm))
2850 fm) 2785 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2851 end) 2786 raise Fail "No name passed to textbox tag"))
2852 2787 | "password" => input "password"
2853 | "ccheckbox" => 2788 | "textarea" =>
2854 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 2789 (case targs of
2855 NONE => 2790 [_, (L.CName name, _)] =>
2856 let 2791 let
2857 val (ts, fm) = tagStart "input type=\"checkbox\"" 2792 val (ts, fm) = tagStart "textarea"
2858 in 2793 val (xml, fm) = monoExp (env, st, fm) xml
2859 ((L'.EStrcat (ts, 2794 in
2860 (L'.EPrim (Prim.String " />"), loc)), 2795 ((L'.EStrcat ((L'.EStrcat (ts,
2861 loc), fm) 2796 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
2862 end 2797 (L'.EStrcat (xml,
2863 | SOME (_, src, _) => 2798 (L'.EPrim (Prim.String "</textarea>"),
2864 let 2799 loc)), loc)),
2865 val sc = strcat [str "chk(exec(", 2800 loc), fm)
2866 (L'.EJavaScript (L'.Script, src), loc), 2801 end
2867 str "))"] 2802 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2868 val sc = setAttrs sc 2803 raise Fail "No name passed to ltextarea tag"))
2869 in 2804
2870 (strcat [str "<script type=\"text/javascript\">", 2805 | "checkbox" => input "checkbox"
2871 sc, 2806 | "upload" => input "file"
2872 str "</script>"], 2807
2873 fm) 2808 | "radio" =>
2874 end) 2809 (case targs of
2875 2810 [_, (L.CName name, _)] =>
2876 | "cselect" => 2811 monoExp (env, St.setRadioGroup (st, name), fm) xml
2877 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 2812 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2878 NONE => 2813 raise Fail "No name passed to radio tag"))
2879 let 2814 | "radioOption" =>
2880 val (xml, fm) = monoExp (env, st, fm) xml 2815 (case St.radioGroup st of
2881 val (ts, fm) = tagStart "select" 2816 NONE => raise Fail "No name for radioGroup"
2882 in 2817 | SOME name =>
2883 (strcat [ts, 2818 normal ("input",
2884 str ">", 2819 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
2885 xml, 2820 NONE))
2886 str "</select>"], 2821
2887 fm) 2822 | "select" =>
2888 end 2823 (case targs of
2889 | SOME (_, src, _) => 2824 [_, (L.CName name, _)] =>
2890 let 2825 let
2891 val (xml, fm) = monoExp (env, st, fm) xml 2826 val (ts, fm) = tagStart "select"
2892 2827 val (xml, fm) = monoExp (env, st, fm) xml
2893 val sc = strcat [str "sel(exec(", 2828 in
2894 (L'.EJavaScript (L'.Script, src), loc), 2829 ((L'.EStrcat ((L'.EStrcat (ts,
2895 str "),exec(", 2830 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
2896 (L'.EJavaScript (L'.Script, xml), loc), 2831 loc)), loc),
2897 str "))"] 2832 (L'.EStrcat (xml,
2898 val sc = setAttrs sc 2833 (L'.EPrim (Prim.String "</select>"),
2899 in 2834 loc)), loc)),
2900 (strcat [str "<script type=\"text/javascript\">", 2835 loc),
2901 sc, 2836 fm)
2902 str "</script>"], 2837 end
2903 fm) 2838 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
2904 end) 2839 raise Fail "No name passed to lselect tag"))
2905 2840
2906 | "coption" => normal ("option", NONE, NONE) 2841 | "ctextbox" =>
2907 2842 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
2908 | "tabl" => normal ("table", NONE, NONE) 2843 NONE =>
2909 | _ => normal (tag, NONE, NONE) 2844 let
2845 val (ts, fm) = tagStart "input"
2846 in
2847 ((L'.EStrcat (ts,
2848 (L'.EPrim (Prim.String " />"), loc)),
2849 loc), fm)
2850 end
2851 | SOME (_, src, _) =>
2852 let
2853 val sc = strcat [str "inp(exec(",
2854 (L'.EJavaScript (L'.Script, src), loc),
2855 str "))"]
2856 val sc = setAttrs sc
2857 in
2858 (strcat [str "<script type=\"text/javascript\">",
2859 sc,
2860 str "</script>"],
2861 fm)
2862 end)
2863
2864 | "ccheckbox" =>
2865 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
2866 NONE =>
2867 let
2868 val (ts, fm) = tagStart "input type=\"checkbox\""
2869 in
2870 ((L'.EStrcat (ts,
2871 (L'.EPrim (Prim.String " />"), loc)),
2872 loc), fm)
2873 end
2874 | SOME (_, src, _) =>
2875 let
2876 val sc = strcat [str "chk(exec(",
2877 (L'.EJavaScript (L'.Script, src), loc),
2878 str "))"]
2879 val sc = setAttrs sc
2880 in
2881 (strcat [str "<script type=\"text/javascript\">",
2882 sc,
2883 str "</script>"],
2884 fm)
2885 end)
2886
2887 | "cselect" =>
2888 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
2889 NONE =>
2890 let
2891 val (xml, fm) = monoExp (env, st, fm) xml
2892 val (ts, fm) = tagStart "select"
2893 in
2894 (strcat [ts,
2895 str ">",
2896 xml,
2897 str "</select>"],
2898 fm)
2899 end
2900 | SOME (_, src, _) =>
2901 let
2902 val (xml, fm) = monoExp (env, st, fm) xml
2903
2904 val sc = strcat [str "sel(exec(",
2905 (L'.EJavaScript (L'.Script, src), loc),
2906 str "),exec(",
2907 (L'.EJavaScript (L'.Script, xml), loc),
2908 str "))"]
2909 val sc = setAttrs sc
2910 in
2911 (strcat [str "<script type=\"text/javascript\">",
2912 sc,
2913 str "</script>"],
2914 fm)
2915 end)
2916
2917 | "coption" => normal ("option", NONE, NONE)
2918
2919 | "tabl" => normal ("table", NONE, NONE)
2920 | _ => normal (tag, NONE, NONE))
2921 before inTag := inT
2910 end 2922 end
2911 2923
2912 | L.EApp ((L.ECApp ( 2924 | L.EApp ((L.ECApp (
2913 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), 2925 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
2914 (L.CRecord (_, fields), _)), _), 2926 (L.CRecord (_, fields), _)), _),
3119 (L'.EReturnBlob {blob = (L'.ERel 2, loc), 3131 (L'.EReturnBlob {blob = (L'.ERel 2, loc),
3120 mimeType = (L'.ERel 1, loc), 3132 mimeType = (L'.ERel 1, loc),
3121 t = t}, loc)), loc)), loc)), loc), 3133 t = t}, loc)), loc)), loc)), loc),
3122 fm) 3134 fm)
3123 end 3135 end
3136 | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
3137 let
3138 val t = monoType env t
3139 val un = (L'.TRecord [], loc)
3140 in
3141 ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
3142 (L'.EAbs ("_", un, t,
3143 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
3144 fm)
3145 end
3124 3146
3125 | L.EApp (e1, e2) => 3147 | L.EApp (e1, e2) =>
3126 let 3148 let
3127 val (e1, fm) = monoExp (env, st, fm) e1 3149 val (e1, fm) = monoExp (env, st, fm) e1
3128 val (e2, fm) = monoExp (env, st, fm) e2 3150 val (e2, fm) = monoExp (env, st, fm) e2
3196 3218
3197 | L.EClosure (n, es) => 3219 | L.EClosure (n, es) =>
3198 let 3220 let
3199 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => 3221 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
3200 monoExp (env, st, fm) e) 3222 monoExp (env, st, fm) e)
3201 fm es 3223 fm es
3202 in 3224 val e = (L'.EClosure (n, es), loc)
3203 ((L'.EClosure (n, es), loc), fm) 3225 in
3226 if !inTag then
3227 (e, fm)
3228 else
3229 urlifyExp env fm (e, dummyTyp)
3204 end 3230 end
3205 3231
3206 | L.ELet (x, t, e1, e2) => 3232 | L.ELet (x, t, e1, e2) =>
3207 let 3233 let
3208 val t' = monoType env t 3234 val t' = monoType env t