Mercurial > urweb

comparison src/monoize.sml @ 2226:e10881cd92da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Fri, 27 Mar 2015 11:26:06 -0400
parents 5709482a2afd f89be9cd2087
children a07b91fa71db
comparison
equal deleted inserted replaced
2225:6262dabc08d6 2226:e10881cd92da
87 ["link", 87 ["link",
88 "br", 88 "br",
89 "p", 89 "p",
90 "hr", 90 "hr",
91 "input", 91 "input",
92 "button",
93 "img", 92 "img",
94 "base", 93 "base",
95 "meta", 94 "meta",
96 "param", 95 "param",
97 "area", 96 "area",
3277 if tag = "body" then 3276 if tag = "body" then
3278 findOnload (attrs, NONE, NONE, []) 3277 findOnload (attrs, NONE, NONE, [])
3279 else 3278 else
3280 (NONE, NONE, attrs) 3279 (NONE, NONE, attrs)
3281 3280
3281 val (class, fm) = monoExp (env, st, fm) class
3282 val (dynClass, fm) = monoExp (env, st, fm) dynClass
3283 val (style, fm) = monoExp (env, st, fm) style
3284 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
3285
3282 (* Special case for <button value=""> *) 3286 (* Special case for <button value=""> *)
3283 val (attrs, extraString) = case tag of 3287 val (attrs, extraString) = case tag of
3284 "button" => 3288 "button" =>
3285 (case List.partition (fn (x, _, _) => x = "Value") attrs of 3289 (case List.partition (fn (x, _, _) => x = "Value") attrs of
3286 ([(_, value, _)], rest) => 3290 ([(_, value, _)], rest) =>
3287 (rest, SOME value) 3291 (rest, SOME value)
3288 | _ => (attrs, NONE)) 3292 | _ => (attrs, NONE))
3293 | "body" =>
3294 (attrs,
3295 if (case (#1 dynClass, #1 dynStyle) of
3296 (L'.ESome _, _) => true
3297 | (_, L'.ESome _) => true
3298 | _ => false) then
3299 let
3300 fun jsify (e : L'.exp) =
3301 case #1 e of
3302 L'.ESome (_, ds) => strcat [str "execD(",
3303 (L'.EJavaScript (L'.Script, ds), loc),
3304 str ")"]
3305 | _ => str "null"
3306 in
3307 SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(",
3308 jsify dynClass,
3309 str ",",
3310 jsify dynStyle,
3311 str ")</script>"])
3312 end
3313 else
3314 NONE)
3289 | _ => (attrs, NONE) 3315 | _ => (attrs, NONE)
3290 3316
3291
3292 val (class, fm) = monoExp (env, st, fm) class
3293 val (dynClass, fm) = monoExp (env, st, fm) dynClass
3294 val (style, fm) = monoExp (env, st, fm) style
3295 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
3296 3317
3297 val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] 3318 val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"]
3298 3319
3299 fun isSome (e, _) = 3320 fun isSome (e, _) =
3300 case e of 3321 case e of
3456 val (tagStart, fm) = tagStart tag 3477 val (tagStart, fm) = tagStart tag
3457 val tagStart = case extra of 3478 val tagStart = case extra of
3458 NONE => tagStart 3479 NONE => tagStart
3459 | SOME extra => (L'.EStrcat (tagStart, extra), loc) 3480 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
3460 3481
3482 val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full
3483
3461 fun normal () = 3484 fun normal () =
3462 let 3485 let
3463 val (xml, fm) = monoExp (env, st, fm) xml 3486 val (xml, fm) = monoExp (env, st, fm) xml
3464 3487
3465 val xml = case extraString of 3488 val xml = case extraString of
3466 NONE => xml 3489 NONE => xml
3467 | SOME extra => (L'.EStrcat (extra, xml), loc) 3490 | SOME extra => (L'.EStrcat (extra, xml), loc)
3468 in 3491 in
3469 ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), 3492 ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc),
3470 (L'.EStrcat (xml, 3493 (L'.EStrcat (xml,
3471 strH (String.concat ["</", tag, ">"])), loc)), 3494 strH (String.concat ["</", firstWord tag, ">"])), loc)),
3472 loc), 3495 loc),
3473 fm) 3496 fm)
3474 end 3497 end
3475 3498
3476 fun isSingleton () = 3499 fun isSingleton () =
3833 fm) 3856 fm)
3834 end) 3857 end)
3835 3858
3836 | "tabl" => normal ("table", NONE) 3859 | "tabl" => normal ("table", NONE)
3837 | _ => normal (tag, NONE) 3860 | _ => normal (tag, NONE)
3861
3862 val (dynClass', dynStyle') =
3863 case tag of
3864 "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan),
3865 (L'.ENone dummyTyp, ErrorMsg.dummySpan))
3866 | _ => (dynClass, dynStyle)
3838 in 3867 in
3839 case #1 dynClass of 3868 case #1 dynClass' of
3840 L'.ENone _ => 3869 L'.ENone _ =>
3841 (case #1 dynStyle of 3870 (case #1 dynStyle' of
3842 L'.ENone _ => baseAll 3871 L'.ENone _ => baseAll
3843 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"", 3872 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
3844 str (pnode ()), 3873 str (pnode ()),
3845 str "\",execD(", 3874 str "\",execD(",
3846 (L'.EJavaScript (L'.Script, base), loc), 3875 (L'.EJavaScript (L'.Script, base), loc),
3850 fm) 3879 fm)
3851 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; 3880 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
3852 baseAll)) 3881 baseAll))
3853 | L'.ESome (_, dc) => 3882 | L'.ESome (_, dc) =>
3854 let 3883 let
3855 val e = case #1 dynStyle of 3884 val e = case #1 dynStyle' of
3856 L'.ENone _ => str "null" 3885 L'.ENone _ => str "null"
3857 | L'.ESome (_, ds) => strcat [str "execD(", 3886 | L'.ESome (_, ds) => strcat [str "execD(",
3858 (L'.EJavaScript (L'.Script, ds), loc), 3887 (L'.EJavaScript (L'.Script, ds), loc),
3859 str ")"] 3888 str ")"]
3860 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; 3889 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";