Mercurial > urweb

comparison src/compiler.sml @ 1082:4b2f50829af5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Alternate job-parsing interface, to avoid merging library directives
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Dec 2009 15:29:38 -0500
parents d069b193ed6b
children 2eb585274501
comparison
equal deleted inserted replaced
1081:25d491287358 1082:4b2f50829af5
99 (if ErrorMsg.anyErrors () then 99 (if ErrorMsg.anyErrors () then
100 NONE 100 NONE
101 else 101 else
102 SOME v, 102 SOME v,
103 (name, elapsed) :: pmap) 103 (name, elapsed) :: pmap)
104 end
105 }
106
107 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
108 func = fn input => case #func tr1 input of
109 NONE => NONE
110 | SOME v => #func tr2 v,
111 print = #print tr2,
112 time = fn (input, pmap) => let
113 val (ro, pmap) = #time tr1 (input, pmap)
114 in
115 case ro of
116 NONE => (NONE, pmap)
117 | SOME v => #time tr2 (v, pmap)
118 end 104 end
119 } 105 }
120 106
121 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); 107 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
122 ignore (#func tr x)) 108 ignore (#func tr x))
282 structure M = BinaryMapFn(struct 268 structure M = BinaryMapFn(struct
283 type ord_key = string 269 type ord_key = string
284 val compare = String.compare 270 val compare = String.compare
285 end) 271 end)
286 272
287 fun parseUrp' fname = 273 fun parseUrp' accLibs fname =
288 let 274 let
289 val pathmap = ref (M.insert (M.empty, "", Config.libUr)) 275 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
276 val bigLibs = ref []
290 277
291 fun pu filename = 278 fun pu filename =
292 let 279 let
293 val dir = OS.Path.dir filename 280 val dir = OS.Path.dir filename
294 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) 281 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
429 sources = #sources new @ #sources old, 416 sources = #sources new @ #sources old,
430 protocol = mergeO #2 (#protocol old, #protocol new), 417 protocol = mergeO #2 (#protocol old, #protocol new),
431 dbms = mergeO #2 (#dbms old, #dbms new) 418 dbms = mergeO #2 (#dbms old, #dbms new)
432 } 419 }
433 in 420 in
434 foldr (fn (job', job) => merge (job, job')) job (!libs) 421 if accLibs then
422 foldr (fn (job', job) => merge (job, job')) job (!libs)
423 else
424 job
435 end 425 end
436 426
437 fun parsePkind s = 427 fun parsePkind s =
438 case s of 428 case s of
439 "all" => Settings.Any 429 "all" => Settings.Any
566 val (kind, pattern) = parsePattern pattern 556 val (kind, pattern) = parsePattern pattern
567 in 557 in
568 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind 558 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
569 end 559 end
570 | _ => ErrorMsg.error "Bad 'deny' syntax") 560 | _ => ErrorMsg.error "Bad 'deny' syntax")
571 | "library" => libs := pu (relify arg) :: !libs 561 | "library" => if accLibs then
562 libs := pu (relify arg) :: !libs
563 else
564 bigLibs := relify arg :: !bigLibs
572 | "path" => 565 | "path" =>
573 (case String.fields (fn ch => ch = #"=") arg of 566 (case String.fields (fn ch => ch = #"=") arg of
574 [n, v] => pathmap := M.insert (!pathmap, n, v) 567 [n, v] => pathmap := M.insert (!pathmap, n, v)
575 | _ => ErrorMsg.error "path argument not of the form name=value'") 568 | _ => ErrorMsg.error "path argument not of the form name=value'")
576 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); 569 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
595 Option.app Settings.setProtocol (#protocol job); 588 Option.app Settings.setProtocol (#protocol job);
596 Option.app Settings.setDbms (#dbms job); 589 Option.app Settings.setDbms (#dbms job);
597 job 590 job
598 end 591 end
599 in 592 in
600 pu fname 593 {Job = pu fname, Libs = !bigLibs}
601 end 594 end
602 595
596 fun p_job' {Job = j, Libs = _ : string list} = p_job j
597
603 val parseUrp = { 598 val parseUrp = {
604 func = parseUrp', 599 func = #Job o parseUrp' false,
605 print = p_job 600 print = p_job
606 } 601 }
607 602
603 val parseUrp' = {
604 func = parseUrp' true,
605 print = p_job'
606 }
607
608 val toParseJob = transform parseUrp "parseJob" 608 val toParseJob = transform parseUrp "parseJob"
609 val toParseJob' = transform parseUrp' "parseJob'"
610
611 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
612 func = fn input => case #func tr1 input of
613 NONE => NONE
614 | SOME v => #func tr2 v,
615 print = #print tr2,
616 time = fn (input, pmap) => let
617 val (ro, pmap) = #time tr1 (input, pmap)
618 in
619 case ro of
620 NONE => (NONE, pmap)
621 | SOME v => #time tr2 (v, pmap)
622 end
623 }
609 624
610 fun capitalize "" = "" 625 fun capitalize "" = ""
611 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 626 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
612 627
613 val parse = { 628 val parse = {