Mercurial > urweb

comparison src/monoize.sml @ 385:1195f6e4d208

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support for URL prefixes that works with local demo
author Adam Chlipala <adamc@hcoop.net>
date Sun, 19 Oct 2008 15:47:47 -0400
parents 260b680a6a04
children 7abb28e9d51f
comparison
equal deleted inserted replaced
384:2a7e7bd7b29f 385:1195f6e4d208
33 structure L = Core 33 structure L = Core
34 structure L' = Mono 34 structure L' = Mono
35 35
36 structure IM = IntBinaryMap 36 structure IM = IntBinaryMap
37 37
38 val urlPrefix = ref "/"
39
38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) 40 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
39 41
40 structure U = MonoUtil 42 structure U = MonoUtil
41 43
42 val liftExpInExp = 44 val liftExpInExp =
262 case #1 e of 264 case #1 e of
263 L'.EClosure (fnam, [(L'.ERecord [], _)]) => 265 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
264 let 266 let
265 val (_, _, _, s) = Env.lookupENamed env fnam 267 val (_, _, _, s) = Env.lookupENamed env fnam
266 in 268 in
267 ((L'.EPrim (Prim.String ("/" ^ s)), loc), fm) 269 ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
268 end 270 end
269 | L'.EClosure (fnam, args) => 271 | L'.EClosure (fnam, args) =>
270 let 272 let
271 val (_, ft, _, s) = Env.lookupENamed env fnam 273 val (_, ft, _, s) = Env.lookupENamed env fnam
272 val ft = monoType env ft 274 val ft = monoType env ft
285 fm) 287 fm)
286 end 288 end
287 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 289 | _ => (E.errorAt loc "Type mismatch encoding attribute";
288 (e, fm)) 290 (e, fm))
289 in 291 in
290 attrify (args, ft, (L'.EPrim (Prim.String ("/" ^ s)), loc), fm) 292 attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
291 end 293 end
292 | _ => 294 | _ =>
293 case t of 295 case t of
294 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) 296 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
295 297
1281 | "Action" => urlifyExp 1283 | "Action" => urlifyExp
1282 | _ => attrifyExp 1284 | _ => attrifyExp
1283 1285
1284 val xp = " " ^ lowercaseFirst x ^ "=\"" 1286 val xp = " " ^ lowercaseFirst x ^ "=\""
1285 1287
1286
1287
1288 val (e, fm) = fooify env fm (e, t) 1288 val (e, fm) = fooify env fm (e, t)
1289 in 1289 in
1290 ((L'.EStrcat (s, 1290 ((L'.EStrcat (s,
1291 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 1291 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
1292 (L'.EStrcat (e, 1292 (L'.EStrcat (e,
1675 | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)]) 1675 | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
1676 end 1676 end
1677 1677
1678 fun monoize env ds = 1678 fun monoize env ds =
1679 let 1679 let
1680 val p = !urlPrefix
1681 val () =
1682 if p = "" then
1683 urlPrefix := "/"
1684 else if String.sub (p, size p - 1) <> #"/" then
1685 urlPrefix := p ^ "/"
1686 else
1687 ()
1688
1680 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 1689 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
1681 case monoDecl (env, fm) d of 1690 case monoDecl (env, fm) d of
1682 NONE => (env, fm, ds) 1691 NONE => (env, fm, ds)
1683 | SOME (env, fm, ds') => 1692 | SOME (env, fm, ds') =>
1684 (env, 1693 (env,