Mercurial > urweb

comparison src/monoize.sml @ 668:b0c1a46b1f15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First message send delivered, but not interpreted
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Mar 2009 15:05:07 -0400
parents a93d5324f400
children f73913d97a40
comparison
equal deleted inserted replaced
667:a93d5324f400 668:b0c1a46b1f15
177 (L'.TRecord [], loc) 177 (L'.TRecord [], loc)
178 | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) => 178 | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
179 (L'.TRecord [], loc) 179 (L'.TRecord [], loc)
180 | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) => 180 | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
181 (L'.TFfi ("Basis", "string"), loc) 181 (L'.TFfi ("Basis", "string"), loc)
182
183 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
184 (L'.TFfi ("Basis", "channel"), loc)
182 185
183 | L.CRel _ => poly () 186 | L.CRel _ => poly ()
184 | L.CNamed n => 187 | L.CNamed n =>
185 (case IM.find (dtmap, n) of 188 (case IM.find (dtmap, n) of
186 SOME r => (L'.TDatatype (n, r), loc) 189 SOME r => (L'.TDatatype (n, r), loc)
1078 (L'.ERel 2, loc), 1081 (L'.ERel 2, loc),
1079 e]), loc)), 1082 e]), loc)),
1080 loc)), loc)), loc), 1083 loc)), loc)), loc),
1081 fm) 1084 fm)
1082 end 1085 end
1086
1087 | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
1088 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
1089 (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc),
1090 fm)
1091 | L.ECApp ((L.EFfi ("Basis", "subscribe"), _), t) =>
1092 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
1093 (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
1094 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1095 (L'.EFfiApp ("Basis", "subscribe",
1096 [(L'.ERel 1, loc)]),
1097 loc)), loc)), loc),
1098 fm)
1099 | L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
1100 let
1101 val t = monoType env t
1102 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
1103 in
1104 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
1105 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
1106 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
1107 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1108 (L'.EFfiApp ("Basis", "send",
1109 [(L'.ERel 2, loc),
1110 e]),
1111 loc)), loc)), loc)), loc),
1112 fm)
1113 end
1083 1114
1084 | L.EFfiApp ("Basis", "dml", [e]) => 1115 | L.EFfiApp ("Basis", "dml", [e]) =>
1085 let 1116 let
1086 val (e, fm) = monoExp (env, st, fm) e 1117 val (e, fm) = monoExp (env, st, fm) e
1087 in 1118 in
1779 val (attrs, fm) = monoExp (env, st, fm) attrs 1810 val (attrs, fm) = monoExp (env, st, fm) attrs
1780 val attrs = case #1 attrs of 1811 val attrs = case #1 attrs of
1781 L'.ERecord xes => xes 1812 L'.ERecord xes => xes
1782 | _ => raise Fail "Non-record attributes!" 1813 | _ => raise Fail "Non-record attributes!"
1783 1814
1815 fun findOnload (attrs, acc) =
1816 case attrs of
1817 [] => (NONE, acc)
1818 | ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
1819 | x :: rest => findOnload (rest, x :: acc)
1820
1821 val (onload, attrs) = findOnload (attrs, [])
1822
1784 fun lowercaseFirst "" = "" 1823 fun lowercaseFirst "" = ""
1785 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) 1824 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
1786 ^ String.extract (s, 1, NONE) 1825 ^ String.extract (s, 1, NONE)
1787 1826
1788 fun tagStart tag = 1827 fun tagStart tag =
1922 :: str ";" 1961 :: str ";"
1923 :: assgns) 1962 :: assgns)
1924 end 1963 end
1925 in 1964 in
1926 case tag of 1965 case tag of
1927 "body" => normal ("body", 1966 "body" =>
1928 SOME (L'.EFfiApp ("Basis", "get_listener", [(L'.ERecord [], loc)]), loc), 1967 let
1929 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) 1968 val onload = case onload of
1969 NONE => (L'.EPrim (Prim.String ""), loc)
1970 | SOME e =>
1971 let
1972 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
1973 in
1974 (L'.EJavaScript (L'.Attribute, e, NONE), loc)
1975 end
1976 in
1977 normal ("body",
1978 SOME (L'.EFfiApp ("Basis", "get_listener", [onload]), loc),
1979 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
1980 end
1930 1981
1931 | "dyn" => 1982 | "dyn" =>
1932 (case attrs of 1983 (case attrs of
1933 [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), 1984 [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
1934 e), _), _)] => (e, fm) 1985 e), _), _)] => (e, fm)