Mercurial > urweb

comparison src/monoize.sml @ 120:6230bdd122e7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Passing an argument to a web function
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 20:07:10 -0400
parents 7207f794b916
children 91027db5a07c
comparison
equal deleted inserted replaced
119:7fdc146b2bc2 120:6230bdd122e7
77 | L.CUnit => poly () 77 | L.CUnit => poly ()
78 end 78 end
79 79
80 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) 80 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
81 81
82 fun attrifyExp env (e, tAll as (t, loc)) = 82 fun fooifyExp name env =
83 case #1 e of 83 let
84 L'.EClosure (fnam, [(L'.ERecord [], _)]) => 84 fun fooify (e, tAll as (t, loc)) =
85 let 85 case #1 e of
86 val (_, _, _, s) = Env.lookupENamed env fnam 86 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
87 in 87 let
88 (L'.EPrim (Prim.String s), loc) 88 val (_, _, _, s) = Env.lookupENamed env fnam
89 end 89 in
90 | L'.EClosure (fnam, args) => 90 (L'.EPrim (Prim.String s), loc)
91 let 91 end
92 val (_, ft, _, s) = Env.lookupENamed env fnam 92 | L'.EClosure (fnam, args) =>
93 val ft = monoType env ft 93 let
94 94 val (_, ft, _, s) = Env.lookupENamed env fnam
95 fun attrify (args, ft, e) = 95 val ft = monoType env ft
96 case (args, ft) of 96
97 ([], _) => e 97 fun attrify (args, ft, e) =
98 | (arg :: args, (L'.TFun (t, ft), _)) => 98 case (args, ft) of
99 (L'.EStrcat (e, 99 ([], _) => e
100 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), 100 | (arg :: args, (L'.TFun (t, ft), _)) =>
101 attrifyExp env (arg, t)), loc)), loc) 101 (L'.EStrcat (e,
102 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 102 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
103 e) 103 fooify (arg, t)), loc)), loc)
104 in 104 | _ => (E.errorAt loc "Type mismatch encoding attribute";
105 attrify (args, ft, (L'.EPrim (Prim.String s), loc)) 105 e)
106 end 106 in
107 | _ => 107 attrify (args, ft, (L'.EPrim (Prim.String s), loc))
108 case t of 108 end
109 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc) 109 | _ =>
110 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc) 110 case t of
111 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc) 111 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", name ^ "ifyString", [e]), loc)
112 | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc) 112 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", name ^ "ifyInt", [e]), loc)
113 113 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
114 | _ => (E.errorAt loc "Don't know how to encode attribute type"; 114 | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
115 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; 115
116 dummyExp) 116 | _ => (E.errorAt loc "Don't know how to encode attribute type";
117 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
118 dummyExp)
119 in
120 fooify
121 end
122
123 val attrifyExp = fooifyExp "attr"
124 val urlifyExp = fooifyExp "url"
117 125
118 fun monoExp env (all as (e, loc)) = 126 fun monoExp env (all as (e, loc)) =
119 let 127 let
120 fun poly () = 128 fun poly () =
121 (E.errorAt loc "Unsupported expression"; 129 (E.errorAt loc "Unsupported expression";
177 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) 185 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
178 in 186 in
179 foldl (fn ((x, e, t), s) => 187 foldl (fn ((x, e, t), s) =>
180 let 188 let
181 val xp = " " ^ lowercaseFirst x ^ "=\"" 189 val xp = " " ^ lowercaseFirst x ^ "=\""
190
191 val fooify =
192 case x of
193 "Link" => urlifyExp
194 | _ => attrifyExp
182 in 195 in
183 (L'.EStrcat (s, 196 (L'.EStrcat (s,
184 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 197 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
185 (L'.EStrcat (attrifyExp env (e, t), 198 (L'.EStrcat (fooify env (e, t),
186 (L'.EPrim (Prim.String "\""), loc)), 199 (L'.EPrim (Prim.String "\""), loc)),
187 loc)), 200 loc)),
188 loc)), loc) 201 loc)), loc)
189 end) 202 end)
190 s xes 203 s xes
234 L.DCon _ => NONE 247 L.DCon _ => NONE
235 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, 248 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
236 (L'.DVal (x, n, monoType env t, monoExp env e, s), loc)) 249 (L'.DVal (x, n, monoType env t, monoExp env e, s), loc))
237 | L.DExport n => 250 | L.DExport n =>
238 let 251 let
239 val (_, _, _, s) = Env.lookupENamed env n 252 val (_, t, _, s) = Env.lookupENamed env n
253
254 fun unwind (t, _) =
255 case t of
256 L.TFun (dom, ran) => dom :: unwind ran
257 | _ => []
258
259 val ts = map (monoType env) (unwind t)
240 in 260 in
241 SOME (env, (L'.DExport (s, n), loc)) 261 SOME (env, (L'.DExport (s, n, ts), loc))
242 end 262 end
243 end 263 end
244 264
245 fun monoize env ds = 265 fun monoize env ds =
246 let 266 let