Mercurial > urweb

comparison src/monoize.sml @ 565:74800be65591

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Creation of sources in server code
author Adam Chlipala <adamc@hcoop.net>
date Fri, 19 Dec 2008 11:47:18 -0500
parents 803b2f3bb86b
children a152905c3c3b
comparison
equal deleted inserted replaced
564:803b2f3bb86b 565:74800be65591
131 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 131 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
132 (L'.TFfi ("Basis", "string"), loc) 132 (L'.TFfi ("Basis", "string"), loc)
133 133
134 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => 134 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
135 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) 135 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
136 | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
137 (L'.TFfi ("Basis", "int"), loc)
136 | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => 138 | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
137 (L'.TFfi ("Basis", "string"), loc) 139 (L'.TFfi ("Basis", "string"), loc)
138 | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => 140 | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
139 (L'.TFfi ("Basis", "string"), loc) 141 (L'.TFfi ("Basis", "string"), loc)
140 | L.CFfi ("Basis", "sql_sequence") => 142 | L.CFfi ("Basis", "sql_sequence") =>
960 (L'.ERecord [], loc)), loc), 962 (L'.ERecord [], loc)), loc),
961 (L'.EApp ( 963 (L'.EApp (
962 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc), 964 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
963 (L'.ERecord [], loc)), 965 (L'.ERecord [], loc)),
964 loc)), loc)), loc)), loc)), loc), 966 loc)), loc)), loc)), loc)), loc),
967 fm)
968 end
969
970 | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
971 let
972 val t = monoType env t
973 in
974 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc),
975 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc),
976 (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)),
977 loc),
965 fm) 978 fm)
966 end 979 end
967 980
968 | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => 981 | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
969 let 982 let
1767 loc)), loc), fm) 1780 loc)), loc), fm)
1768 end 1781 end
1769 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 1782 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
1770 raise Fail "No name passed to input tag") 1783 raise Fail "No name passed to input tag")
1771 1784
1772 fun normal (tag, extra) = 1785 fun normal (tag, extra, extraInner) =
1773 let 1786 let
1774 val (tagStart, fm) = tagStart tag 1787 val (tagStart, fm) = tagStart tag
1775 val tagStart = case extra of 1788 val tagStart = case extra of
1776 NONE => tagStart 1789 NONE => tagStart
1777 | SOME extra => (L'.EStrcat (tagStart, extra), loc) 1790 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
1778 1791
1779 fun normal () = 1792 fun normal () =
1780 let 1793 let
1781 val (xml, fm) = monoExp (env, st, fm) xml 1794 val (xml, fm) = monoExp (env, st, fm) xml
1795 val xml = case extraInner of
1796 NONE => xml
1797 | SOME ei => (L'.EStrcat (ei, xml), loc)
1782 in 1798 in
1783 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), 1799 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
1784 (L'.EStrcat (xml, 1800 (L'.EStrcat (xml,
1785 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), 1801 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
1786 loc)), loc)), 1802 loc)), loc)),
1800 normal () 1816 normal ()
1801 | _ => normal () 1817 | _ => normal ()
1802 end 1818 end
1803 in 1819 in
1804 case tag of 1820 case tag of
1805 "submit" => normal ("input type=\"submit\"", NONE) 1821 "body" => normal ("body", NONE,
1822 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
1823
1824 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
1806 1825
1807 | "textbox" => 1826 | "textbox" =>
1808 (case targs of 1827 (case targs of
1809 [_, (L.CName name, _)] => 1828 [_, (L.CName name, _)] =>
1810 let 1829 let
1845 | "radioOption" => 1864 | "radioOption" =>
1846 (case St.radioGroup st of 1865 (case St.radioGroup st of
1847 NONE => raise Fail "No name for radioGroup" 1866 NONE => raise Fail "No name for radioGroup"
1848 | SOME name => 1867 | SOME name =>
1849 normal ("input", 1868 normal ("input",
1850 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc))) 1869 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
1870 NONE))
1851 1871
1852 | "select" => 1872 | "select" =>
1853 (case targs of 1873 (case targs of
1854 [_, (L.CName name, _)] => 1874 [_, (L.CName name, _)] =>
1855 let 1875 let
1865 fm) 1885 fm)
1866 end 1886 end
1867 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 1887 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
1868 raise Fail "No name passed to lselect tag")) 1888 raise Fail "No name passed to lselect tag"))
1869 1889
1870 | "option" => normal ("option", NONE) 1890 | "option" => normal ("option", NONE, NONE)
1871 1891
1872 | "tabl" => normal ("table", NONE) 1892 | "tabl" => normal ("table", NONE, NONE)
1873 | _ => normal (tag, NONE) 1893 | _ => normal (tag, NONE, NONE)
1874 end 1894 end
1875 1895
1876 | L.EApp ((L.ECApp ( 1896 | L.EApp ((L.ECApp (
1877 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), 1897 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
1878 _), _), 1898 _), _),