Mercurial > urweb

comparison src/monoize.sml @ 1067:50dd937c4cb9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Bug fixes in redirect-related stuff
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Dec 2009 15:46:07 -0500
parents 217eb87dde31
children e933297c4e24
comparison
equal deleted inserted replaced
1066:740b85ef4352 1067:50dd937c4cb9
392 fun capitalize s = 392 fun capitalize s =
393 if s = "" then 393 if s = "" then
394 s 394 s
395 else 395 else
396 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 396 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
397
398 val inTag = ref false
399 397
400 fun fooifyExp fk env = 398 fun fooifyExp fk env =
401 let 399 let
402 fun fooify fm (e, tAll as (t, loc)) = 400 fun fooify fm (e, tAll as (t, loc)) =
403 case #1 e of 401 case #1 e of
2478 class), _), 2476 class), _),
2479 attrs), _), 2477 attrs), _),
2480 tag), _), 2478 tag), _),
2481 xml) => 2479 xml) =>
2482 let 2480 let
2483 val inT = !inTag
2484 val () = inTag := true
2485
2486 fun getTag' (e, _) = 2481 fun getTag' (e, _) =
2487 case e of 2482 case e of
2488 L.EFfi ("Basis", tag) => (tag, []) 2483 L.EFfi ("Basis", tag) => (tag, [])
2489 | L.ECApp (e, t) => let 2484 | L.ECApp (e, t) => let
2490 val (tag, ts) = getTag' e 2485 val (tag, ts) = getTag' e
2916 2911
2917 | "coption" => normal ("option", NONE, NONE) 2912 | "coption" => normal ("option", NONE, NONE)
2918 2913
2919 | "tabl" => normal ("table", NONE, NONE) 2914 | "tabl" => normal ("table", NONE, NONE)
2920 | _ => normal (tag, NONE, NONE)) 2915 | _ => normal (tag, NONE, NONE))
2921 before inTag := inT
2922 end 2916 end
2923 2917
2924 | L.EApp ((L.ECApp ( 2918 | L.EApp ((L.ECApp (
2925 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), 2919 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
2926 (L.CRecord (_, fields), _)), _), 2920 (L.CRecord (_, fields), _)), _),
3142 (L'.EAbs ("_", un, t, 3136 (L'.EAbs ("_", un, t,
3143 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc), 3137 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
3144 fm) 3138 fm)
3145 end 3139 end
3146 3140
3141 | L.EFfiApp ("Basis", "url", [e]) =>
3142 let
3143 val (e, fm) = monoExp (env, st, fm) e
3144 in
3145 urlifyExp env fm (e, dummyTyp)
3146 end
3147
3147 | L.EApp (e1, e2) => 3148 | L.EApp (e1, e2) =>
3148 let 3149 let
3149 val (e1, fm) = monoExp (env, st, fm) e1 3150 val (e1, fm) = monoExp (env, st, fm) e1
3150 val (e2, fm) = monoExp (env, st, fm) e2 3151 val (e2, fm) = monoExp (env, st, fm) e2
3151 in 3152 in
3221 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => 3222 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
3222 monoExp (env, st, fm) e) 3223 monoExp (env, st, fm) e)
3223 fm es 3224 fm es
3224 val e = (L'.EClosure (n, es), loc) 3225 val e = (L'.EClosure (n, es), loc)
3225 in 3226 in
3226 if !inTag then 3227 (e, fm)
3227 (e, fm)
3228 else
3229 urlifyExp env fm (e, dummyTyp)
3230 end 3228 end
3231 3229
3232 | L.ELet (x, t, e1, e2) => 3230 | L.ELet (x, t, e1, e2) =>
3233 let 3231 let
3234 val t' = monoType env t 3232 val t' = monoType env t