Mercurial > urweb

comparison src/compiler.sml @ 794:dc3fc3f3b834

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Improving/reordering Unpoly and Especialize; pathmaps
author Adam Chlipala <adamc@hcoop.net>
date Thu, 14 May 2009 08:13:54 -0400
parents d20d6afc1206
children 249740301a0a
comparison
equal deleted inserted replaced
793:3e5d1c6ae30c 794:dc3fc3f3b834
265 val (s, _) = Substring.splitr Char.isSpace s 265 val (s, _) = Substring.splitr Char.isSpace s
266 in 266 in
267 s 267 s
268 end 268 end
269 269
270 fun parseUrp' filename = 270 structure M = BinaryMapFn(struct
271 type ord_key = string
272 val compare = String.compare
273 end)
274
275 fun parseUrp' fname =
271 let 276 let
272 val dir = OS.Path.dir filename 277 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
273 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) 278
274 279 fun pu filename =
275 fun relify fname =
276 OS.Path.concat (dir, fname)
277 handle OS.Path.Path => fname
278
279 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
280
281 fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
282
283 fun readSources acc =
284 case TextIO.inputLine inf of
285 NONE => rev acc
286 | SOME line =>
287 let
288 val acc = if CharVector.all Char.isSpace line then
289 acc
290 else
291 let
292 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
293 (String.explode line))
294 val fname = relify fname
295 in
296 fname :: acc
297 end
298 in
299 readSources acc
300 end
301
302 val prefix = ref NONE
303 val database = ref NONE
304 val exe = ref NONE
305 val sql = ref NONE
306 val debug = ref false
307 val profile = ref false
308 val timeout = ref NONE
309 val ffi = ref []
310 val link = ref []
311 val headers = ref []
312 val scripts = ref []
313 val clientToServer = ref []
314 val effectful = ref []
315 val clientOnly = ref []
316 val serverOnly = ref []
317 val jsFuncs = ref []
318 val rewrites = ref []
319 val url = ref []
320 val mime = ref []
321 val libs = ref []
322
323 fun finish sources =
324 let 280 let
325 val job = { 281 val dir = OS.Path.dir filename
326 prefix = Option.getOpt (!prefix, "/"), 282 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
327 database = !database, 283
328 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, 284 fun pathify fname =
329 ext = SOME "exe"}), 285 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
330 sql = !sql, 286 let
331 debug = !debug, 287 val fname' = Substring.extract (fname, 1, NONE)
332 profile = !profile, 288 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
333 timeout = Option.getOpt (!timeout, 60), 289 in
334 ffi = rev (!ffi), 290 if Substring.isEmpty after then
335 link = rev (!link), 291 fname
336 headers = rev (!headers), 292 else
337 scripts = rev (!scripts), 293 case M.find (!pathmap, Substring.string befor) of
338 clientToServer = rev (!clientToServer), 294 NONE => fname
339 effectful = rev (!effectful), 295 | SOME rep => rep ^ Substring.string after
340 clientOnly = rev (!clientOnly), 296 end
341 serverOnly = rev (!serverOnly), 297 else
342 jsFuncs = rev (!jsFuncs), 298 fname
343 rewrites = rev (!rewrites), 299
344 filterUrl = rev (!url), 300 fun relify fname =
345 filterMime = rev (!mime), 301 let
346 sources = sources 302 val fname = pathify fname
347 } 303 in
348 304 OS.Path.concat (dir, fname)
349 fun mergeO f (old, new) = 305 handle OS.Path.Path => fname
350 case (old, new) of 306 end
351 (NONE, _) => new 307
352 | (_, NONE) => old 308 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
353 | (SOME v1, SOME v2) => SOME (f (v1, v2)) 309
354 310 fun relifyA fname =
355 fun same desc = mergeO (fn (x : string, y) => 311 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
356 (if x = y then 312
357 () 313 fun readSources acc =
358 else 314 case TextIO.inputLine inf of
359 ErrorMsg.error ("Multiple " 315 NONE => rev acc
360 ^ desc ^ " values that don't agree"); 316 | SOME line =>
361 x)) 317 let
362 318 val acc = if CharVector.all Char.isSpace line then
363 fun merge (old : job, new : job) = { 319 acc
364 prefix = #prefix old, 320 else
365 database = #database old, 321 let
366 exe = #exe old, 322 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
367 sql = #sql old, 323 (String.explode line))
368 debug = #debug old orelse #debug new, 324 val fname = relify fname
369 profile = #profile old orelse #profile new, 325 in
370 timeout = #timeout old, 326 fname :: acc
371 ffi = #ffi old @ #ffi new, 327 end
372 link = #link old @ #link new, 328 in
373 headers = #headers old @ #headers new, 329 readSources acc
374 scripts = #scripts old @ #scripts new, 330 end
375 clientToServer = #clientToServer old @ #clientToServer new, 331
376 effectful = #effectful old @ #effectful new, 332 val prefix = ref NONE
377 clientOnly = #clientOnly old @ #clientOnly new, 333 val database = ref NONE
378 serverOnly = #serverOnly old @ #serverOnly new, 334 val exe = ref NONE
379 jsFuncs = #jsFuncs old @ #jsFuncs new, 335 val sql = ref NONE
380 rewrites = #rewrites old @ #rewrites new, 336 val debug = ref false
381 filterUrl = #filterUrl old @ #filterUrl new, 337 val profile = ref false
382 filterMime = #filterMime old @ #filterMime new, 338 val timeout = ref NONE
383 sources = #sources new @ #sources old 339 val ffi = ref []
384 } 340 val link = ref []
341 val headers = ref []
342 val scripts = ref []
343 val clientToServer = ref []
344 val effectful = ref []
345 val clientOnly = ref []
346 val serverOnly = ref []
347 val jsFuncs = ref []
348 val rewrites = ref []
349 val url = ref []
350 val mime = ref []
351 val libs = ref []
352
353 fun finish sources =
354 let
355 val job = {
356 prefix = Option.getOpt (!prefix, "/"),
357 database = !database,
358 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
359 ext = SOME "exe"}),
360 sql = !sql,
361 debug = !debug,
362 profile = !profile,
363 timeout = Option.getOpt (!timeout, 60),
364 ffi = rev (!ffi),
365 link = rev (!link),
366 headers = rev (!headers),
367 scripts = rev (!scripts),
368 clientToServer = rev (!clientToServer),
369 effectful = rev (!effectful),
370 clientOnly = rev (!clientOnly),
371 serverOnly = rev (!serverOnly),
372 jsFuncs = rev (!jsFuncs),
373 rewrites = rev (!rewrites),
374 filterUrl = rev (!url),
375 filterMime = rev (!mime),
376 sources = sources
377 }
378
379 fun mergeO f (old, new) =
380 case (old, new) of
381 (NONE, _) => new
382 | (_, NONE) => old
383 | (SOME v1, SOME v2) => SOME (f (v1, v2))
384
385 fun same desc = mergeO (fn (x : string, y) =>
386 (if x = y then
387 ()
388 else
389 ErrorMsg.error ("Multiple "
390 ^ desc ^ " values that don't agree");
391 x))
392
393 fun merge (old : job, new : job) = {
394 prefix = #prefix old,
395 database = #database old,
396 exe = #exe old,
397 sql = #sql old,
398 debug = #debug old orelse #debug new,
399 profile = #profile old orelse #profile new,
400 timeout = #timeout old,
401 ffi = #ffi old @ #ffi new,
402 link = #link old @ #link new,
403 headers = #headers old @ #headers new,
404 scripts = #scripts old @ #scripts new,
405 clientToServer = #clientToServer old @ #clientToServer new,
406 effectful = #effectful old @ #effectful new,
407 clientOnly = #clientOnly old @ #clientOnly new,
408 serverOnly = #serverOnly old @ #serverOnly new,
409 jsFuncs = #jsFuncs old @ #jsFuncs new,
410 rewrites = #rewrites old @ #rewrites new,
411 filterUrl = #filterUrl old @ #filterUrl new,
412 filterMime = #filterMime old @ #filterMime new,
413 sources = #sources new @ #sources old
414 }
415 in
416 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
417 end
418
419 fun parsePkind s =
420 case s of
421 "all" => Settings.Any
422 | "url" => Settings.Url
423 | "table" => Settings.Table
424 | "sequence" => Settings.Sequence
425 | "view" => Settings.View
426 | "relation" => Settings.Relation
427 | "cookie" => Settings.Cookie
428 | "style" => Settings.Style
429 | _ => (ErrorMsg.error "Bad path kind spec";
430 Settings.Any)
431
432 fun parseFrom s =
433 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
434 (Settings.Prefix, String.substring (s, 0, size s - 1))
435 else
436 (Settings.Exact, s)
437
438 fun parseFkind s =
439 case s of
440 "url" => url
441 | "mime" => mime
442 | _ => (ErrorMsg.error "Bad filter kind";
443 url)
444
445 fun parsePattern s =
446 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
447 (Settings.Prefix, String.substring (s, 0, size s - 1))
448 else
449 (Settings.Exact, s)
450
451 fun read () =
452 case TextIO.inputLine inf of
453 NONE => finish []
454 | SOME "\n" => finish (readSources [])
455 | SOME line =>
456 let
457 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
458 val cmd = Substring.string (trim cmd)
459 val arg = Substring.string (trim arg)
460
461 fun ffiS () =
462 case String.fields (fn ch => ch = #".") arg of
463 [m, x] => (m, x)
464 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
465 ("", ""))
466
467 fun ffiM () =
468 case String.fields (fn ch => ch = #"=") arg of
469 [f, s] =>
470 (case String.fields (fn ch => ch = #".") f of
471 [m, x] => ((m, x), s)
472 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
473 (("", ""), "")))
474 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
475 (("", ""), ""))
476 in
477 case cmd of
478 "prefix" =>
479 (case !prefix of
480 NONE => ()
481 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
482 prefix := SOME arg)
483 | "database" =>
484 (case !database of
485 NONE => ()
486 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
487 database := SOME arg)
488 | "exe" =>
489 (case !exe of
490 NONE => ()
491 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
492 exe := SOME (relify arg))
493 | "sql" =>
494 (case !sql of
495 NONE => ()
496 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
497 sql := SOME (relify arg))
498 | "debug" => debug := true
499 | "profile" => profile := true
500 | "timeout" =>
501 (case !timeout of
502 NONE => ()
503 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
504 timeout := SOME (valOf (Int.fromString arg)))
505 | "ffi" => ffi := relify arg :: !ffi
506 | "link" => link := relifyA arg :: !link
507 | "include" => headers := relifyA arg :: !headers
508 | "script" => scripts := arg :: !scripts
509 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
510 | "effectful" => effectful := ffiS () :: !effectful
511 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
512 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
513 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
514 | "rewrite" =>
515 let
516 fun doit (pkind, from, to) =
517 let
518 val pkind = parsePkind pkind
519 val (kind, from) = parseFrom from
520 in
521 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
522 end
523 in
524 case String.tokens Char.isSpace arg of
525 [pkind, from, to] => doit (pkind, from, to)
526 | [pkind, from] => doit (pkind, from, "")
527 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
528 end
529 | "allow" =>
530 (case String.tokens Char.isSpace arg of
531 [fkind, pattern] =>
532 let
533 val fkind = parseFkind fkind
534 val (kind, pattern) = parsePattern pattern
535 in
536 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
537 end
538 | _ => ErrorMsg.error "Bad 'allow' syntax")
539 | "deny" =>
540 (case String.tokens Char.isSpace arg of
541 [fkind, pattern] =>
542 let
543 val fkind = parseFkind fkind
544 val (kind, pattern) = parsePattern pattern
545 in
546 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
547 end
548 | _ => ErrorMsg.error "Bad 'deny' syntax")
549 | "library" => libs := relify arg :: !libs
550 | "path" =>
551 (case String.fields (fn ch => ch = #"=") arg of
552 [n, v] => pathmap := M.insert (!pathmap, n, v)
553 | _ => ErrorMsg.error "path argument not of the form name=value'")
554 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
555 read ()
556 end
557
558 val job = read ()
385 in 559 in
386 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) 560 TextIO.closeIn inf;
561 Settings.setUrlPrefix (#prefix job);
562 Settings.setTimeout (#timeout job);
563 Settings.setHeaders (#headers job);
564 Settings.setScripts (#scripts job);
565 Settings.setClientToServer (#clientToServer job);
566 Settings.setEffectful (#effectful job);
567 Settings.setClientOnly (#clientOnly job);
568 Settings.setServerOnly (#serverOnly job);
569 Settings.setJsFuncs (#jsFuncs job);
570 Settings.setRewriteRules (#rewrites job);
571 Settings.setUrlRules (#filterUrl job);
572 Settings.setMimeRules (#filterMime job);
573 job
387 end 574 end
388
389 fun parsePkind s =
390 case s of
391 "all" => Settings.Any
392 | "url" => Settings.Url
393 | "table" => Settings.Table
394 | "sequence" => Settings.Sequence
395 | "view" => Settings.View
396 | "relation" => Settings.Relation
397 | "cookie" => Settings.Cookie
398 | "style" => Settings.Style
399 | _ => (ErrorMsg.error "Bad path kind spec";
400 Settings.Any)
401
402 fun parseFrom s =
403 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
404 (Settings.Prefix, String.substring (s, 0, size s - 1))
405 else
406 (Settings.Exact, s)
407
408 fun parseFkind s =
409 case s of
410 "url" => url
411 | "mime" => mime
412 | _ => (ErrorMsg.error "Bad filter kind";
413 url)
414
415 fun parsePattern s =
416 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
417 (Settings.Prefix, String.substring (s, 0, size s - 1))
418 else
419 (Settings.Exact, s)
420
421 fun read () =
422 case TextIO.inputLine inf of
423 NONE => finish []
424 | SOME "\n" => finish (readSources [])
425 | SOME line =>
426 let
427 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
428 val cmd = Substring.string (trim cmd)
429 val arg = Substring.string (trim arg)
430
431 fun ffiS () =
432 case String.fields (fn ch => ch = #".") arg of
433 [m, x] => (m, x)
434 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
435 ("", ""))
436
437 fun ffiM () =
438 case String.fields (fn ch => ch = #"=") arg of
439 [f, s] =>
440 (case String.fields (fn ch => ch = #".") f of
441 [m, x] => ((m, x), s)
442 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
443 (("", ""), "")))
444 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
445 (("", ""), ""))
446 in
447 case cmd of
448 "prefix" =>
449 (case !prefix of
450 NONE => ()
451 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
452 prefix := SOME arg)
453 | "database" =>
454 (case !database of
455 NONE => ()
456 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
457 database := SOME arg)
458 | "exe" =>
459 (case !exe of
460 NONE => ()
461 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
462 exe := SOME (relify arg))
463 | "sql" =>
464 (case !sql of
465 NONE => ()
466 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
467 sql := SOME (relify arg))
468 | "debug" => debug := true
469 | "profile" => profile := true
470 | "timeout" =>
471 (case !timeout of
472 NONE => ()
473 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
474 timeout := SOME (valOf (Int.fromString arg)))
475 | "ffi" => ffi := relify arg :: !ffi
476 | "link" => link := relifyA arg :: !link
477 | "include" => headers := relifyA arg :: !headers
478 | "script" => scripts := arg :: !scripts
479 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
480 | "effectful" => effectful := ffiS () :: !effectful
481 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
482 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
483 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
484 | "rewrite" =>
485 let
486 fun doit (pkind, from, to) =
487 let
488 val pkind = parsePkind pkind
489 val (kind, from) = parseFrom from
490 in
491 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
492 end
493 in
494 case String.tokens Char.isSpace arg of
495 [pkind, from, to] => doit (pkind, from, to)
496 | [pkind, from] => doit (pkind, from, "")
497 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
498 end
499 | "allow" =>
500 (case String.tokens Char.isSpace arg of
501 [fkind, pattern] =>
502 let
503 val fkind = parseFkind fkind
504 val (kind, pattern) = parsePattern pattern
505 in
506 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
507 end
508 | _ => ErrorMsg.error "Bad 'allow' syntax")
509 | "deny" =>
510 (case String.tokens Char.isSpace arg of
511 [fkind, pattern] =>
512 let
513 val fkind = parseFkind fkind
514 val (kind, pattern) = parsePattern pattern
515 in
516 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
517 end
518 | _ => ErrorMsg.error "Bad 'deny' syntax")
519 | "library" => libs := relify arg :: !libs
520 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
521 read ()
522 end
523
524 val job = read ()
525 in 575 in
526 TextIO.closeIn inf; 576 pu fname
527 Settings.setUrlPrefix (#prefix job);
528 Settings.setTimeout (#timeout job);
529 Settings.setHeaders (#headers job);
530 Settings.setScripts (#scripts job);
531 Settings.setClientToServer (#clientToServer job);
532 Settings.setEffectful (#effectful job);
533 Settings.setClientOnly (#clientOnly job);
534 Settings.setServerOnly (#serverOnly job);
535 Settings.setJsFuncs (#jsFuncs job);
536 Settings.setRewriteRules (#rewrites job);
537 Settings.setUrlRules (#filterUrl job);
538 Settings.setMimeRules (#filterMime job);
539 job
540 end 577 end
541 578
542 val parseUrp = { 579 val parseUrp = {
543 func = parseUrp', 580 func = parseUrp',
544 print = p_job 581 print = p_job
667 val especialize = { 704 val especialize = {
668 func = ESpecialize.specialize, 705 func = ESpecialize.specialize,
669 print = CorePrint.p_file CoreEnv.empty 706 print = CorePrint.p_file CoreEnv.empty
670 } 707 }
671 708
672 val toEspecialize = transform especialize "especialize" o toCorify
673
674 val core_untangle = { 709 val core_untangle = {
675 func = CoreUntangle.untangle, 710 func = CoreUntangle.untangle,
676 print = CorePrint.p_file CoreEnv.empty 711 print = CorePrint.p_file CoreEnv.empty
677 } 712 }
678 713
679 val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize 714 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
680 715
681 val shake = { 716 val shake = {
682 func = Shake.shake, 717 func = Shake.shake,
683 print = CorePrint.p_file CoreEnv.empty 718 print = CorePrint.p_file CoreEnv.empty
684 } 719 }
723 758
724 val toSpecialize = transform specialize "specialize" o toUnpoly 759 val toSpecialize = transform specialize "specialize" o toUnpoly
725 760
726 val toShake3 = transform shake "shake3" o toSpecialize 761 val toShake3 = transform shake "shake3" o toSpecialize
727 762
763 val toEspecialize = transform especialize "especialize" o toShake3
764
765 val toShake4 = transform shake "shake4" o toEspecialize
766
728 val marshalcheck = { 767 val marshalcheck = {
729 func = (fn file => (MarshalCheck.check file; file)), 768 func = (fn file => (MarshalCheck.check file; file)),
730 print = CorePrint.p_file CoreEnv.empty 769 print = CorePrint.p_file CoreEnv.empty
731 } 770 }
732 771
733 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake3 772 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake4
734 773
735 val effectize = { 774 val effectize = {
736 func = Effective.effectize, 775 func = Effective.effectize,
737 print = CorePrint.p_file CoreEnv.empty 776 print = CorePrint.p_file CoreEnv.empty
738 } 777 }