Mercurial > urweb

comparison src/monoize.sml @ 153:cfe6f9db74aa

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
radio and radioOption
author Adam Chlipala <adamc@hcoop.net>
date Thu, 24 Jul 2008 11:10:23 -0400
parents 67ab26888839
children e2b185379592
comparison
equal deleted inserted replaced
152:67ab26888839 153:cfe6f9db74aa
128 datatype 'a failable_search = 128 datatype 'a failable_search =
129 Found of 'a 129 Found of 'a
130 | NotFound 130 | NotFound
131 | Error 131 | Error
132 132
133 fun monoExp env (all as (e, loc)) = 133 structure St :> sig
134 type t
135
136 val empty : t
137
138 val radioGroup : t -> string option
139 val setRadioGroup : t * string -> t
140 end = struct
141
142 type t = {
143 radioGroup : string option
144 }
145
146 val empty = {radioGroup = NONE}
147
148 fun radioGroup (t : t) = #radioGroup t
149
150 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
151
152 end
153
154 fun monoExp (env, st) (all as (e, loc)) =
134 let 155 let
135 fun poly () = 156 fun poly () =
136 (E.errorAt loc "Unsupported expression"; 157 (E.errorAt loc "Unsupported expression";
137 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 158 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
138 dummyExp) 159 dummyExp)
140 case e of 161 case e of
141 L.EPrim p => (L'.EPrim p, loc) 162 L.EPrim p => (L'.EPrim p, loc)
142 | L.ERel n => (L'.ERel n, loc) 163 | L.ERel n => (L'.ERel n, loc)
143 | L.ENamed n => (L'.ENamed n, loc) 164 | L.ENamed n => (L'.ENamed n, loc)
144 | L.EFfi mx => (L'.EFfi mx, loc) 165 | L.EFfi mx => (L'.EFfi mx, loc)
145 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc) 166 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc)
146 167
147 | L.EApp ( 168 | L.EApp (
148 (L.ECApp ( 169 (L.ECApp (
149 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), 170 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
150 _), _), 171 _), _),
151 se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc) 172 se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp (env, st) se]), loc)
152 | L.EApp ( 173 | L.EApp (
153 (L.EApp ( 174 (L.EApp (
154 (L.ECApp ( 175 (L.ECApp (
155 (L.ECApp ( 176 (L.ECApp (
156 (L.ECApp ( 177 (L.ECApp (
159 _), _), _), 180 _), _), _),
160 _), _), 181 _), _),
161 _), _), 182 _), _),
162 _), _), 183 _), _),
163 xml1), _), 184 xml1), _),
164 xml2) => (L'.EStrcat (monoExp env xml1, monoExp env xml2), loc) 185 xml2) => (L'.EStrcat (monoExp (env, st) xml1, monoExp (env, st) xml2), loc)
165 186
166 | L.EApp ( 187 | L.EApp (
167 (L.EApp ( 188 (L.EApp (
168 (L.EApp ( 189 (L.EApp (
169 (L.ECApp ( 190 (L.ECApp (
200 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 221 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
201 ("", [])) 222 ("", []))
202 223
203 val (tag, targs) = getTag tag 224 val (tag, targs) = getTag tag
204 225
205 val attrs = monoExp env attrs 226 val attrs = monoExp (env, st) attrs
206 227
207 fun tagStart tag = 228 fun tagStart tag =
208 case #1 attrs of 229 case #1 attrs of
209 L'.ERecord xes => 230 L'.ERecord xes =>
210 let 231 let
241 [(L.CName name, _)] => 262 [(L.CName name, _)] =>
242 (L'.EStrcat (tagStart "input", 263 (L'.EStrcat (tagStart "input",
243 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")), 264 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
244 loc)), loc) 265 loc)), loc)
245 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 266 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
246 raise Fail "No named passed to input tag") 267 raise Fail "No name passed to input tag")
247 268
248 fun normal (tag, extra) = 269 fun normal (tag, extra) =
249 let 270 let
250 val tagStart = tagStart tag 271 val tagStart = tagStart tag
251 val tagStart = case extra of 272 val tagStart = case extra of
252 NONE => tagStart 273 NONE => tagStart
253 | SOME extra => (L'.EStrcat (tagStart, extra), loc) 274 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
254 275
255 fun normal () = 276 fun normal () =
256 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), 277 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
257 (L'.EStrcat (monoExp env xml, 278 (L'.EStrcat (monoExp (env, st) xml,
258 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), 279 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
259 loc)), loc)), 280 loc)), loc)),
260 loc) 281 loc)
261 in 282 in
262 case xml of 283 case xml of
280 [_, (L.CName name, _)] => 301 [_, (L.CName name, _)] =>
281 (L'.EStrcat (tagStart "input", 302 (L'.EStrcat (tagStart "input",
282 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), 303 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
283 loc)), loc) 304 loc)), loc)
284 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 305 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
285 raise Fail "No named passed to textarea tag")) 306 raise Fail "No name passed to textarea tag"))
286 | "ltextarea" => 307 | "ltextarea" =>
287 (case targs of 308 (case targs of
288 [_, (L.CName name, _)] => 309 [_, (L.CName name, _)] =>
289 (L'.EStrcat ((L'.EStrcat (tagStart "textarea", 310 (L'.EStrcat ((L'.EStrcat (tagStart "textarea",
290 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 311 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
291 (L'.EStrcat (monoExp env xml, 312 (L'.EStrcat (monoExp (env, st) xml,
292 (L'.EPrim (Prim.String "</textarea>"), 313 (L'.EPrim (Prim.String "</textarea>"),
293 loc)), loc)), 314 loc)), loc)),
294 loc) 315 loc)
295 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 316 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
296 raise Fail "No named passed to ltextarea tag")) 317 raise Fail "No name passed to ltextarea tag"))
318
319 | "radio" =>
320 (case targs of
321 [_, (L.CName name, _)] =>
322 monoExp (env, St.setRadioGroup (st, name)) xml
323 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
324 raise Fail "No name passed to radio tag"))
325 | "radioOption" =>
326 (case St.radioGroup st of
327 NONE => raise Fail "No name for radioGroup"
328 | SOME name =>
329 normal ("input",
330 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
297 331
298 | _ => normal (tag, NONE) 332 | _ => normal (tag, NONE)
299 end 333 end
300 334
301 | L.EApp ((L.ECApp ( 335 | L.EApp ((L.ECApp (
356 NotFound => raise Fail "No submit found" 390 NotFound => raise Fail "No submit found"
357 | Error => raise Fail "Not ready for multi-submit lforms yet" 391 | Error => raise Fail "Not ready for multi-submit lforms yet"
358 | Found et => et 392 | Found et => et
359 393
360 val actionT = monoType env actionT 394 val actionT = monoType env actionT
361 val action = monoExp env action 395 val action = monoExp (env, st) action
362 in 396 in
363 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), 397 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
364 (L'.EStrcat (urlifyExp env (action, actionT), 398 (L'.EStrcat (urlifyExp env (action, actionT),
365 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), 399 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
366 (L'.EStrcat (monoExp env xml, 400 (L'.EStrcat (monoExp (env, st) xml,
367 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) 401 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
368 end 402 end
369 403
370 | L.EApp ((L.ECApp ( 404 | L.EApp ((L.ECApp (
371 (L.ECApp ( 405 (L.ECApp (
373 (L.ECApp ( 407 (L.ECApp (
374 (L.EFfi ("Basis", "useMore"), _), _), _), 408 (L.EFfi ("Basis", "useMore"), _), _), _),
375 _), _), 409 _), _),
376 _), _), 410 _), _),
377 _), _), 411 _), _),
378 xml) => monoExp env xml 412 xml) => monoExp (env, st) xml
379 413
380 414
381 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc) 415 | L.EApp (e1, e2) => (L'.EApp (monoExp (env, st) e1, monoExp (env, st) e2), loc)
382 | L.EAbs (x, dom, ran, e) => 416 | L.EAbs (x, dom, ran, e) =>
383 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc) 417 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom, st) e), loc)
384 | L.ECApp _ => poly () 418 | L.ECApp _ => poly ()
385 | L.ECAbs _ => poly () 419 | L.ECAbs _ => poly ()
386 420
387 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc) 421 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x,
388 | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) 422 monoExp (env, st) e,
423 monoType env t)) xes), loc)
424 | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc)
389 | L.ECut _ => poly () 425 | L.ECut _ => poly ()
390 | L.EFold _ => poly () 426 | L.EFold _ => poly ()
391 | L.EWrite e => (L'.EWrite (monoExp env e), loc) 427 | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc)
392 428
393 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp env) es), loc) 429 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc)
394 end 430 end
395 431
396 fun monoDecl env (all as (d, loc)) = 432 fun monoDecl env (all as (d, loc)) =
397 let 433 let
398 fun poly () = 434 fun poly () =
401 NONE) 437 NONE)
402 in 438 in
403 case d of 439 case d of
404 L.DCon _ => NONE 440 L.DCon _ => NONE
405 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, 441 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
406 (L'.DVal (x, n, monoType env t, monoExp env e, s), loc)) 442 (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
407 | L.DValRec vis => 443 | L.DValRec vis =>
408 let 444 let
409 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis 445 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
410 in 446 in
411 SOME (env, 447 SOME (env,
412 (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, monoExp env e, s)) vis), loc)) 448 (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t,
449 monoExp (env, St.empty) e, s)) vis), loc))
413 end 450 end
414 | L.DExport (ek, n) => 451 | L.DExport (ek, n) =>
415 let 452 let
416 val (_, t, _, s) = Env.lookupENamed env n 453 val (_, t, _, s) = Env.lookupENamed env n
417 454