Mercurial > urweb

comparison src/compiler.sml @ 768:3b7e46790fa7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Path rewriting
author Adam Chlipala <adamc@hcoop.net>
date Sat, 02 May 2009 13:23:07 -0400
parents d27ed5ddeb52
children efceae06df17
comparison
equal deleted inserted replaced
767:d27ed5ddeb52 768:3b7e46790fa7
48 scripts : string list, 48 scripts : string list,
49 clientToServer : Settings.ffi list, 49 clientToServer : Settings.ffi list,
50 effectful : Settings.ffi list, 50 effectful : Settings.ffi list,
51 clientOnly : Settings.ffi list, 51 clientOnly : Settings.ffi list,
52 serverOnly : Settings.ffi list, 52 serverOnly : Settings.ffi list,
53 jsFuncs : (Settings.ffi * string) list 53 jsFuncs : (Settings.ffi * string) list,
54 rewrites : Settings.rewrite list
54 } 55 }
55 56
56 type ('src, 'dst) phase = { 57 type ('src, 'dst) phase = {
57 func : 'src -> 'dst, 58 func : 'src -> 'dst,
58 print : 'dst -> Print.PD.pp_desc 59 print : 'dst -> Print.PD.pp_desc
206 | _ => absyn 207 | _ => absyn
207 end 208 end
208 handle LrParser.ParseError => [], 209 handle LrParser.ParseError => [],
209 print = SourcePrint.p_file} 210 print = SourcePrint.p_file}
210 211
211 fun p_job {prefix, database, exe, sql, sources, debug, profile, 212 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
212 timeout, ffi, link, headers, scripts, 213 timeout, ffi, link, headers, scripts,
213 clientToServer, effectful, clientOnly, serverOnly, jsFuncs} = 214 clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
214 let 215 let
215 open Print.PD 216 open Print.PD
216 open Print 217 open Print
217 218
218 fun p_ffi name = p_list_sep (box []) (fn (m, s) => 219 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
310 val clientToServer = ref [] 311 val clientToServer = ref []
311 val effectful = ref [] 312 val effectful = ref []
312 val clientOnly = ref [] 313 val clientOnly = ref []
313 val serverOnly = ref [] 314 val serverOnly = ref []
314 val jsFuncs = ref [] 315 val jsFuncs = ref []
316 val rewrites = ref []
315 val libs = ref [] 317 val libs = ref []
316 318
317 fun finish sources = 319 fun finish sources =
318 let 320 let
319 val job = { 321 val job = {
332 clientToServer = rev (!clientToServer), 334 clientToServer = rev (!clientToServer),
333 effectful = rev (!effectful), 335 effectful = rev (!effectful),
334 clientOnly = rev (!clientOnly), 336 clientOnly = rev (!clientOnly),
335 serverOnly = rev (!serverOnly), 337 serverOnly = rev (!serverOnly),
336 jsFuncs = rev (!jsFuncs), 338 jsFuncs = rev (!jsFuncs),
339 rewrites = rev (!rewrites),
337 sources = sources 340 sources = sources
338 } 341 }
339 342
340 fun mergeO f (old, new) = 343 fun mergeO f (old, new) =
341 case (old, new) of 344 case (old, new) of
366 clientToServer = #clientToServer old @ #clientToServer new, 369 clientToServer = #clientToServer old @ #clientToServer new,
367 effectful = #effectful old @ #effectful new, 370 effectful = #effectful old @ #effectful new,
368 clientOnly = #clientOnly old @ #clientOnly new, 371 clientOnly = #clientOnly old @ #clientOnly new,
369 serverOnly = #serverOnly old @ #serverOnly new, 372 serverOnly = #serverOnly old @ #serverOnly new,
370 jsFuncs = #jsFuncs old @ #jsFuncs new, 373 jsFuncs = #jsFuncs old @ #jsFuncs new,
374 rewrites = #rewrites old @ #rewrites new,
371 sources = #sources old @ #sources new 375 sources = #sources old @ #sources new
372 } 376 }
373 in 377 in
374 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) 378 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
375 end 379 end
380
381 fun parsePkind s =
382 case s of
383 "all" => Settings.Any
384 | "url" => Settings.Url
385 | "table" => Settings.Table
386 | "sequence" => Settings.Sequence
387 | "view" => Settings.View
388 | "relation" => Settings.Relation
389 | "cookie" => Settings.Cookie
390 | "style" => Settings.Style
391 | _ => (ErrorMsg.error "Bad path kind spec";
392 Settings.Any)
393
394 fun parseFrom s =
395 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
396 (Settings.Prefix, String.substring (s, 0, size s - 1))
397 else
398 (Settings.Exact, s)
376 399
377 fun read () = 400 fun read () =
378 case TextIO.inputLine inf of 401 case TextIO.inputLine inf of
379 NONE => finish [] 402 NONE => finish []
380 | SOME "\n" => finish (readSources []) 403 | SOME "\n" => finish (readSources [])
435 | "clientToServer" => clientToServer := ffiS () :: !clientToServer 458 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
436 | "effectful" => effectful := ffiS () :: !effectful 459 | "effectful" => effectful := ffiS () :: !effectful
437 | "clientOnly" => clientOnly := ffiS () :: !clientOnly 460 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
438 | "serverOnly" => serverOnly := ffiS () :: !serverOnly 461 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
439 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs 462 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
463 | "rewrite" =>
464 let
465 fun doit (pkind, from, to) =
466 let
467 val pkind = parsePkind pkind
468 val (kind, from) = parseFrom from
469 in
470 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
471 end
472 in
473 case String.tokens Char.isSpace arg of
474 [pkind, from, to] => doit (pkind, from, to)
475 | [pkind, from] => doit (pkind, from, "")
476 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
477 end
440 | "library" => libs := relify arg :: !libs 478 | "library" => libs := relify arg :: !libs
441 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); 479 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
442 read () 480 read ()
443 end 481 end
444 482
452 Settings.setClientToServer (#clientToServer job); 490 Settings.setClientToServer (#clientToServer job);
453 Settings.setEffectful (#effectful job); 491 Settings.setEffectful (#effectful job);
454 Settings.setClientOnly (#clientOnly job); 492 Settings.setClientOnly (#clientOnly job);
455 Settings.setServerOnly (#serverOnly job); 493 Settings.setServerOnly (#serverOnly job);
456 Settings.setJsFuncs (#jsFuncs job); 494 Settings.setJsFuncs (#jsFuncs job);
495 Settings.setRewriteRules (#rewrites job);
457 job 496 job
458 end 497 end
459 498
460 val parseUrp = { 499 val parseUrp = {
461 func = parseUrp', 500 func = parseUrp',