Mercurial > urweb

comparison src/monoize.sml @ 2206:c1a62ce47083

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Tue, 27 May 2014 21:38:01 -0400
parents 2b2d07946e65
children 924e2ef31f5a
comparison
equal deleted inserted replaced
2205:cdea39473c78 2206:c1a62ce47083
1 (* Copyright (c) 2008-2013, Adam Chlipala 1 (* Copyright (c) 2008-2014, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
233 | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc) 233 | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc)
234 | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc) 234 | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc)
235 | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc) 235 | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc)
236 | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc) 236 | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc)
237 | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc) 237 | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc)
238 | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
238 239
239 | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) => 240 | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
240 (L'.TFfi ("Basis", "string"), loc) 241 (L'.TFfi ("Basis", "string"), loc)
241 242
242 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => 243 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
2129 sc " GROUP BY ", 2130 sc " GROUP BY ",
2130 strcatComma (map (fn (x, xts) => 2131 strcatComma (map (fn (x, xts) =>
2131 strcatComma 2132 strcatComma
2132 (map (fn (x', _) => 2133 (map (fn (x', _) =>
2133 sc ("T_" ^ x 2134 sc ("T_" ^ x
2134 ^ "" 2135 ^ "."
2135 ^ Settings.mangleSql x')) 2136 ^ Settings.mangleSql x'))
2136 xts)) grouped) 2137 xts)) grouped)
2137 ], 2138 ],
2138 2139
2139 (L'.ECase (gf "Having", 2140 (L'.ECase (gf "Having",
3115 in 3116 in
3116 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), 3117 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
3117 fm) 3118 fm)
3118 end 3119 end
3119 3120
3121 | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) =>
3122 let
3123 val (s1, fm) = monoExp (env, st, fm) s1
3124 val (s2, fm) = monoExp (env, st, fm) s2
3125 in
3126 ((L'.EStrcat ((L'.EPrim (Prim.String "data-"), loc),
3127 (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
3128 (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc),
3129 (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
3130 (L'.EPrim (Prim.String "\""), loc)), loc)),
3131 loc)), loc)), loc),
3132 fm)
3133 end
3134
3135 | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) =>
3136 let
3137 val (s1, fm) = monoExp (env, st, fm) s1
3138 val (s2, fm) = monoExp (env, st, fm) s2
3139 in
3140 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
3141 fm)
3142 end
3143
3120 | L.EFfiApp ("Basis", "css_url", [(s, _)]) => 3144 | L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
3121 let 3145 let
3122 val (s, fm) = monoExp (env, st, fm) s 3146 val (s, fm) = monoExp (env, st, fm) s
3123 in 3147 in
3124 ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc), 3148 ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc),
3204 (L.ECApp ( 3228 (L.ECApp (
3205 (L.ECApp ( 3229 (L.ECApp (
3206 (L.ECApp ( 3230 (L.ECApp (
3207 (L.ECApp ( 3231 (L.ECApp (
3208 (L.EFfi ("Basis", "tag"), 3232 (L.EFfi ("Basis", "tag"),
3209 _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), 3233 _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _),
3210 class), _), 3234 class), _),
3211 dynClass), _), 3235 dynClass), _),
3212 style), _), 3236 style), _),
3213 dynStyle), _), 3237 dynStyle), _),
3214 attrs), _), 3238 attrs), _),
3315 {disc = t, 3339 {disc = t,
3316 result = t}), loc)), loc) 3340 result = t}), loc)), loc)
3317 3341
3318 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc 3342 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
3319 | (("Source", _, _), acc) => acc 3343 | (("Source", _, _), acc) => acc
3344 | (("Data", e, _), (s, fm)) =>
3345 ((L'.EStrcat (s,
3346 (L'.EStrcat (
3347 (L'.EPrim (Prim.String " "), loc),
3348 e), loc)), loc),
3349 fm)
3320 | ((x, e, t), (s, fm)) => 3350 | ((x, e, t), (s, fm)) =>
3321 case t of 3351 case t of
3322 (L'.TFfi ("Basis", "bool"), _) => 3352 (L'.TFfi ("Basis", "bool"), _) =>
3323 let 3353 let
3324 val s' = " " ^ lowercaseFirst x 3354 val s' = " " ^ lowercaseFirst x
3549 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), 3579 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
3550 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), 3580 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
3551 (L'.EPrim (Prim.String ")"), loc)), loc)), loc) 3581 (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
3552 end 3582 end
3553 3583
3584 fun inTag tag' = case ctxOuter of
3585 (L.CRecord (_, ctx), _) =>
3586 List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
3587 | _ => false) ctx
3588 | _ => false
3589
3590 fun pnode () = if inTag "Tr" then
3591 "tr"
3592 else if inTag "Table" then
3593 "table"
3594 else
3595 "span"
3596
3554 val baseAll as (base, fm) = 3597 val baseAll as (base, fm) =
3555 case tag of 3598 case tag of
3556 "body" => let 3599 "body" => let
3557 val onload = execify onload 3600 val onload = execify onload
3558 val onunload = execify onunload 3601 val onunload = execify onunload
3571 loc)), loc)) 3614 loc)), loc))
3572 end 3615 end
3573 3616
3574 | "dyn" => 3617 | "dyn" =>
3575 let 3618 let
3576 fun inTag tag = case targs of
3577 (L.CRecord (_, ctx), _) :: _ =>
3578 List.exists (fn ((L.CName tag', _), _) => tag' = tag
3579 | _ => false) ctx
3580 | _ => false
3581
3582 val tag = if inTag "Tr" then
3583 "tr"
3584 else if inTag "Table" then
3585 "table"
3586 else
3587 "span"
3588 in 3619 in
3589 case attrs of 3620 case attrs of
3590 [("Signal", e, _)] => 3621 [("Signal", e, _)] =>
3591 ((L'.EStrcat 3622 ((L'.EStrcat
3592 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" 3623 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
3593 ^ tag ^ "\", execD(")), loc), 3624 ^ pnode () ^ "\", execD(")), loc),
3594 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 3625 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
3595 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 3626 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
3596 fm) 3627 fm)
3597 | _ => raise Fail "Monoize: Bad <dyn> attributes" 3628 | _ => raise Fail "Monoize: Bad <dyn> attributes"
3598 end 3629 end
3802 in 3833 in
3803 case #1 dynClass of 3834 case #1 dynClass of
3804 L'.ENone _ => 3835 L'.ENone _ =>
3805 (case #1 dynStyle of 3836 (case #1 dynStyle of
3806 L'.ENone _ => baseAll 3837 L'.ENone _ => baseAll
3807 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(", 3838 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
3839 str (pnode ()),
3840 str "\",execD(",
3808 (L'.EJavaScript (L'.Script, base), loc), 3841 (L'.EJavaScript (L'.Script, base), loc),
3809 str "),null,execD(", 3842 str "),null,execD(",
3810 (L'.EJavaScript (L'.Script, ds), loc), 3843 (L'.EJavaScript (L'.Script, ds), loc),
3811 str "))</script>"], 3844 str "))</script>"],
3812 fm) 3845 fm)
3820 (L'.EJavaScript (L'.Script, ds), loc), 3853 (L'.EJavaScript (L'.Script, ds), loc),
3821 str ")"] 3854 str ")"]
3822 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; 3855 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
3823 str "null") 3856 str "null")
3824 in 3857 in
3825 (strcat [str "<script type=\"text/javascript\">dynClass(execD(", 3858 (strcat [str "<script type=\"text/javascript\">dynClass(\"",
3859 str (pnode ()),
3860 str "\",execD(",
3826 (L'.EJavaScript (L'.Script, base), loc), 3861 (L'.EJavaScript (L'.Script, base), loc),
3827 str "),execD(", 3862 str "),execD(",
3828 (L'.EJavaScript (L'.Script, dc), loc), 3863 (L'.EJavaScript (L'.Script, dc), loc),
3829 str "),", 3864 str "),",
3830 e, 3865 e,