Mercurial > urweb

comparison src/monoize.sml @ 1643:b0720700c36e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'dynClass' pseudo-attribute
author Adam Chlipala <adam@chlipala.net>
date Tue, 27 Dec 2011 16:20:48 -0500
parents 2b312f6d4007
children ca3b73a7b4d0
comparison
equal deleted inserted replaced
1642:c3627f317bfd 1643:b0720700c36e
2965 2965
2966 | L.EApp ( 2966 | L.EApp (
2967 (L.EApp ( 2967 (L.EApp (
2968 (L.EApp ( 2968 (L.EApp (
2969 (L.EApp ( 2969 (L.EApp (
2970 (L.ECApp ( 2970 (L.EApp (
2971 (L.ECApp ( 2971 (L.ECApp (
2972 (L.ECApp ( 2972 (L.ECApp (
2973 (L.ECApp ( 2973 (L.ECApp (
2974 (L.ECApp ( 2974 (L.ECApp (
2975 (L.ECApp ( 2975 (L.ECApp (
2976 (L.ECApp ( 2976 (L.ECApp (
2977 (L.ECApp ( 2977 (L.ECApp (
2978 (L.EFfi ("Basis", "tag"), 2978 (L.ECApp (
2979 _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), 2979 (L.EFfi ("Basis", "tag"),
2980 class), _), 2980 _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
2981 class), _),
2982 dynClass), _),
2981 attrs), _), 2983 attrs), _),
2982 tag), _), 2984 tag), _),
2983 xml) => 2985 xml) =>
2984 let 2986 let
2985 fun getTag' (e, _) = 2987 fun getTag' (e, _) =
3028 | x :: rest => findOnload (rest, onload, onunload, x :: acc) 3030 | x :: rest => findOnload (rest, onload, onunload, x :: acc)
3029 3031
3030 val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, []) 3032 val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
3031 3033
3032 val (class, fm) = monoExp (env, st, fm) class 3034 val (class, fm) = monoExp (env, st, fm) class
3035 val (dynClass, fm) = monoExp (env, st, fm) dynClass
3033 3036
3034 fun tagStart tag' = 3037 fun tagStart tag' =
3035 let 3038 let
3036 val t = (L'.TFfi ("Basis", "string"), loc) 3039 val t = (L'.TFfi ("Basis", "string"), loc)
3037 val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) 3040 val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc)
3265 in 3268 in
3266 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), 3269 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
3267 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), 3270 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
3268 (L'.EPrim (Prim.String ")"), loc)), loc)), loc) 3271 (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
3269 end 3272 end
3270 in 3273
3271 (case tag of 3274 val baseAll as (base, fm) =
3272 "body" => let 3275 case tag of
3273 val onload = execify onload 3276 "body" => let
3274 val onunload = execify onunload 3277 val onload = execify onload
3275 in 3278 val onunload = execify onunload
3276 normal ("body", 3279 in
3277 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", 3280 normal ("body",
3278 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", 3281 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
3279 [(L'.ERecord [], loc)]), loc), 3282 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
3280 onload), loc)]), 3283 [(L'.ERecord [], loc)]), loc),
3281 loc), 3284 onload), loc)]),
3282 (L'.EFfiApp ("Basis", "maybe_onunload", 3285 loc),
3283 [onunload]), 3286 (L'.EFfiApp ("Basis", "maybe_onunload",
3284 loc)), loc), 3287 [onunload]),
3285 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) 3288 loc)), loc),
3286 end 3289 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
3287 3290 end
3288 | "dyn" => 3291
3289 let 3292 | "dyn" =>
3290 fun inTag tag = case targs of 3293 let
3291 (L.CRecord (_, ctx), _) :: _ => 3294 fun inTag tag = case targs of
3292 List.exists (fn ((L.CName tag', _), _) => tag' = tag 3295 (L.CRecord (_, ctx), _) :: _ =>
3293 | _ => false) ctx 3296 List.exists (fn ((L.CName tag', _), _) => tag' = tag
3294 | _ => false 3297 | _ => false) ctx
3295 3298 | _ => false
3296 val tag = if inTag "Tr" then 3299
3297 "tr" 3300 val tag = if inTag "Tr" then
3298 else if inTag "Table" then 3301 "tr"
3299 "table" 3302 else if inTag "Table" then
3300 else 3303 "table"
3301 "span" 3304 else
3302 in 3305 "span"
3303 case attrs of 3306 in
3304 [("Signal", e, _)] => 3307 case attrs of
3305 ((L'.EStrcat 3308 [("Signal", e, _)] =>
3306 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" 3309 ((L'.EStrcat
3307 ^ tag ^ "\", execD(")), loc), 3310 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
3308 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 3311 ^ tag ^ "\", execD(")), loc),
3309 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 3312 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
3310 fm) 3313 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
3311 | _ => raise Fail "Monoize: Bad dyn attributes" 3314 fm)
3312 end 3315 | _ => raise Fail "Monoize: Bad dyn attributes"
3313 3316 end
3314 | "submit" => normal ("input type=\"submit\"", NONE, NONE) 3317
3315 | "image" => normal ("input type=\"image\"", NONE, NONE) 3318 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
3316 | "button" => normal ("input type=\"submit\"", NONE, NONE) 3319 | "image" => normal ("input type=\"image\"", NONE, NONE)
3317 | "hidden" => input "hidden" 3320 | "button" => normal ("input type=\"submit\"", NONE, NONE)
3318 3321 | "hidden" => input "hidden"
3319 | "textbox" => 3322
3320 (case targs of 3323 | "textbox" =>
3321 [_, (L.CName name, _)] => 3324 (case targs of
3322 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 3325 [_, (L.CName name, _)] =>
3323 NONE => 3326 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
3324 let 3327 NONE =>
3325 val (ts, fm) = tagStart "input" 3328 let
3326 in 3329 val (ts, fm) = tagStart "input"
3327 ((L'.EStrcat (ts, 3330 in
3328 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")), 3331 ((L'.EStrcat (ts,
3329 loc)), loc), fm) 3332 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")),
3330 end 3333 loc)), loc), fm)
3331 | SOME (_, src, _) => 3334 end
3332 (strcat [str "<script type=\"text/javascript\">inp(exec(", 3335 | SOME (_, src, _) =>
3333 (L'.EJavaScript (L'.Script, src), loc), 3336 (strcat [str "<script type=\"text/javascript\">inp(exec(",
3334 str "), \"", 3337 (L'.EJavaScript (L'.Script, src), loc),
3335 str name, 3338 str "), \"",
3336 str "\")</script>"], 3339 str name,
3337 fm)) 3340 str "\")</script>"],
3338 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3341 fm))
3339 raise Fail "No name passed to textbox tag")) 3342 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3340 | "password" => input "password" 3343 raise Fail "No name passed to textbox tag"))
3341 | "textarea" => 3344 | "password" => input "password"
3342 (case targs of 3345 | "textarea" =>
3343 [_, (L.CName name, _)] => 3346 (case targs of
3344 let 3347 [_, (L.CName name, _)] =>
3345 val (ts, fm) = tagStart "textarea" 3348 let
3346 val (xml, fm) = monoExp (env, st, fm) xml 3349 val (ts, fm) = tagStart "textarea"
3347 in 3350 val (xml, fm) = monoExp (env, st, fm) xml
3348 ((L'.EStrcat ((L'.EStrcat (ts, 3351 in
3349 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 3352 ((L'.EStrcat ((L'.EStrcat (ts,
3350 (L'.EStrcat (xml, 3353 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
3351 (L'.EPrim (Prim.String "</textarea>"), 3354 (L'.EStrcat (xml,
3352 loc)), loc)), 3355 (L'.EPrim (Prim.String "</textarea>"),
3353 loc), fm) 3356 loc)), loc)),
3354 end 3357 loc), fm)
3355 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3358 end
3356 raise Fail "No name passed to ltextarea tag")) 3359 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3357 3360 raise Fail "No name passed to ltextarea tag"))
3358 | "checkbox" => input "checkbox" 3361
3359 | "upload" => input "file" 3362 | "checkbox" => input "checkbox"
3360 3363 | "upload" => input "file"
3361 | "radio" => 3364
3362 (case targs of 3365 | "radio" =>
3363 [_, (L.CName name, _)] => 3366 (case targs of
3364 monoExp (env, St.setRadioGroup (st, name), fm) xml 3367 [_, (L.CName name, _)] =>
3365 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3368 monoExp (env, St.setRadioGroup (st, name), fm) xml
3366 raise Fail "No name passed to radio tag")) 3369 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3367 | "radioOption" => 3370 raise Fail "No name passed to radio tag"))
3368 (case St.radioGroup st of 3371 | "radioOption" =>
3369 NONE => raise Fail "No name for radioGroup" 3372 (case St.radioGroup st of
3370 | SOME name => 3373 NONE => raise Fail "No name for radioGroup"
3371 normal ("input", 3374 | SOME name =>
3372 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), 3375 normal ("input",
3373 NONE)) 3376 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
3374 3377 NONE))
3375 | "select" => 3378
3376 (case targs of 3379 | "select" =>
3377 [_, (L.CName name, _)] => 3380 (case targs of
3378 let 3381 [_, (L.CName name, _)] =>
3379 val (ts, fm) = tagStart "select" 3382 let
3380 val (xml, fm) = monoExp (env, st, fm) xml 3383 val (ts, fm) = tagStart "select"
3381 in 3384 val (xml, fm) = monoExp (env, st, fm) xml
3382 ((L'.EStrcat ((L'.EStrcat (ts, 3385 in
3383 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), 3386 ((L'.EStrcat ((L'.EStrcat (ts,
3384 loc)), loc), 3387 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
3385 (L'.EStrcat (xml, 3388 loc)), loc),
3386 (L'.EPrim (Prim.String "</select>"), 3389 (L'.EStrcat (xml,
3387 loc)), loc)), 3390 (L'.EPrim (Prim.String "</select>"),
3388 loc), 3391 loc)), loc)),
3389 fm) 3392 loc),
3390 end 3393 fm)
3391 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3394 end
3392 raise Fail "No name passed to lselect tag")) 3395 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3393 3396 raise Fail "No name passed to lselect tag"))
3394 | "ctextbox" => 3397
3395 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 3398 | "ctextbox" =>
3396 NONE => 3399 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
3397 let 3400 NONE =>
3398 val (ts, fm) = tagStart "input" 3401 let
3399 in 3402 val (ts, fm) = tagStart "input"
3400 ((L'.EStrcat (ts, 3403 in
3401 (L'.EPrim (Prim.String " />"), loc)), 3404 ((L'.EStrcat (ts,
3402 loc), fm) 3405 (L'.EPrim (Prim.String " />"), loc)),
3403 end 3406 loc), fm)
3404 | SOME (_, src, _) => 3407 end
3405 let 3408 | SOME (_, src, _) =>
3406 val sc = strcat [str "inp(exec(", 3409 let
3407 (L'.EJavaScript (L'.Script, src), loc), 3410 val sc = strcat [str "inp(exec(",
3408 str "))"] 3411 (L'.EJavaScript (L'.Script, src), loc),
3409 val sc = setAttrs sc 3412 str "))"]
3410 in 3413 val sc = setAttrs sc
3411 (strcat [str "<script type=\"text/javascript\">", 3414 in
3412 sc, 3415 (strcat [str "<script type=\"text/javascript\">",
3413 str "</script>"], 3416 sc,
3414 fm) 3417 str "</script>"],
3415 end) 3418 fm)
3416 3419 end)
3417 | "ccheckbox" => 3420
3418 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 3421 | "ccheckbox" =>
3419 NONE => 3422 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
3420 let 3423 NONE =>
3421 val (ts, fm) = tagStart "input type=\"checkbox\"" 3424 let
3422 in 3425 val (ts, fm) = tagStart "input type=\"checkbox\""
3423 ((L'.EStrcat (ts, 3426 in
3424 (L'.EPrim (Prim.String " />"), loc)), 3427 ((L'.EStrcat (ts,
3425 loc), fm) 3428 (L'.EPrim (Prim.String " />"), loc)),
3426 end 3429 loc), fm)
3427 | SOME (_, src, _) => 3430 end
3428 let 3431 | SOME (_, src, _) =>
3429 val sc = strcat [str "chk(exec(", 3432 let
3430 (L'.EJavaScript (L'.Script, src), loc), 3433 val sc = strcat [str "chk(exec(",
3431 str "))"] 3434 (L'.EJavaScript (L'.Script, src), loc),
3432 val sc = setAttrs sc 3435 str "))"]
3433 in 3436 val sc = setAttrs sc
3434 (strcat [str "<script type=\"text/javascript\">", 3437 in
3435 sc, 3438 (strcat [str "<script type=\"text/javascript\">",
3436 str "</script>"], 3439 sc,
3437 fm) 3440 str "</script>"],
3438 end) 3441 fm)
3439 3442 end)
3440 | "cselect" => 3443
3441 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 3444 | "cselect" =>
3442 NONE => 3445 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
3443 let 3446 NONE =>
3444 val (xml, fm) = monoExp (env, st, fm) xml 3447 let
3445 val (ts, fm) = tagStart "select" 3448 val (xml, fm) = monoExp (env, st, fm) xml
3446 in 3449 val (ts, fm) = tagStart "select"
3447 (strcat [ts, 3450 in
3448 str ">", 3451 (strcat [ts,
3449 xml, 3452 str ">",
3450 str "</select>"], 3453 xml,
3451 fm) 3454 str "</select>"],
3452 end 3455 fm)
3453 | SOME (_, src, _) => 3456 end
3454 let 3457 | SOME (_, src, _) =>
3455 val (xml, fm) = monoExp (env, st, fm) xml 3458 let
3456 3459 val (xml, fm) = monoExp (env, st, fm) xml
3457 val sc = strcat [str "sel(exec(", 3460
3458 (L'.EJavaScript (L'.Script, src), loc), 3461 val sc = strcat [str "sel(exec(",
3459 str "),exec(", 3462 (L'.EJavaScript (L'.Script, src), loc),
3460 (L'.EJavaScript (L'.Script, xml), loc), 3463 str "),exec(",
3461 str "))"] 3464 (L'.EJavaScript (L'.Script, xml), loc),
3462 val sc = setAttrs sc 3465 str "))"]
3463 in 3466 val sc = setAttrs sc
3464 (strcat [str "<script type=\"text/javascript\">", 3467 in
3465 sc, 3468 (strcat [str "<script type=\"text/javascript\">",
3466 str "</script>"], 3469 sc,
3467 fm) 3470 str "</script>"],
3468 end) 3471 fm)
3469 3472 end)
3470 | "coption" => normal ("option", NONE, NONE) 3473
3471 3474 | "coption" => normal ("option", NONE, NONE)
3472 | "ctextarea" => 3475
3473 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of 3476 | "ctextarea" =>
3474 NONE => 3477 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
3475 let 3478 NONE =>
3476 val (ts, fm) = tagStart "textarea" 3479 let
3477 in 3480 val (ts, fm) = tagStart "textarea"
3478 ((L'.EStrcat (ts, 3481 in
3479 (L'.EPrim (Prim.String " />"), loc)), 3482 ((L'.EStrcat (ts,
3480 loc), fm) 3483 (L'.EPrim (Prim.String " />"), loc)),
3481 end 3484 loc), fm)
3482 | SOME (_, src, _) => 3485 end
3483 let 3486 | SOME (_, src, _) =>
3484 val sc = strcat [str "tbx(exec(", 3487 let
3485 (L'.EJavaScript (L'.Script, src), loc), 3488 val sc = strcat [str "tbx(exec(",
3486 str "))"] 3489 (L'.EJavaScript (L'.Script, src), loc),
3487 val sc = setAttrs sc 3490 str "))"]
3488 in 3491 val sc = setAttrs sc
3489 (strcat [str "<script type=\"text/javascript\">", 3492 in
3490 sc, 3493 (strcat [str "<script type=\"text/javascript\">",
3491 str "</script>"], 3494 sc,
3492 fm) 3495 str "</script>"],
3493 end) 3496 fm)
3494 3497 end)
3495 | "tabl" => normal ("table", NONE, NONE) 3498
3496 | _ => normal (tag, NONE, NONE)) 3499 | "tabl" => normal ("table", NONE, NONE)
3500 | _ => normal (tag, NONE, NONE)
3501 in
3502 case #1 dynClass of
3503 L'.ENone _ => baseAll
3504 | _ => (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
3505 (L'.EJavaScript (L'.Script, base), loc),
3506 str "),execD(",
3507 (L'.EJavaScript (L'.Script, dynClass), loc),
3508 str "))</script>"],
3509 fm)
3497 end 3510 end
3498 3511
3499 | L.EApp ( 3512 | L.EApp (
3500 (L.EApp ((L.ECApp ( 3513 (L.EApp ((L.ECApp (
3501 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), 3514 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),