interpret.ml 22 KB
Newer Older
1 2 3 4 5 6 7
(* This module is in charge of handling the [--interpret] option,
   if it is present. *)

module I = Invariant (* artificial dependency; ensures that [Invariant] runs first *)

(* --------------------------------------------------------------------------- *)

8
open Grammar
9 10 11
open SentenceParserAux

(* An error message. *)
12

13 14
type message =
  string
15

16 17 18 19
(* A run is a series of sentences or comments together with an error message. *)

type run =
  located_sentence or_comment list * message
20

21 22 23 24 25 26 27 28 29
(* A targeted sentence is a located sentence together with the target into
   which it leads. A target tells us which state a sentence leads to, as well
   as which spurious reductions are performed at the end. *)

type target =
  ReferenceInterpreter.target

let target2state (s, _spurious) =
  s
30

31
type maybe_targeted_sentence =
32
  located_sentence * target option
33

34
type targeted_sentence =
35
  located_sentence * target
36 37 38

(* A targeted run is a series of targeted sentences or comments together with
   an error message. *)
39

40
type maybe_targeted_run =
41
  maybe_targeted_sentence or_comment list * message
42

43 44 45 46 47 48 49 50
type targeted_run =
  targeted_sentence or_comment list * message

(* A filtered targeted run is a series of targeted sentences together with an
   error message. (The comments have been filtered out.) *)

type filtered_targeted_run =
  targeted_sentence list * message
51 52

(* --------------------------------------------------------------------------- *)
POTTIER Francois's avatar
POTTIER Francois committed
53

54
(* Display and debugging. *)
55 56 57 58

let print_sentence (nto, terminals) : string =
  let b = Buffer.create 128 in
  Option.iter (fun nt ->
59
    Printf.bprintf b "%s: " (Nonterminal.print false nt)
60 61 62 63 64 65 66
  ) nto;
  List.iter (fun t ->
    Printf.bprintf b "%s " (Terminal.print t)
  ) terminals;
  Printf.bprintf b "\n";
  Buffer.contents b

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
(* --------------------------------------------------------------------------- *)

(* [stream] turns a finite list of terminals into a stream of terminals. *)

exception EndOfStream

let stream (toks : Terminal.t list) : unit -> Terminal.t * Lexing.position * Lexing.position =
  let toks = ref toks in
  fun () ->

    let tok =
      match !toks with
      | tok :: more ->

	  (* Take a token off the list, and return it. *)

	  toks := more;
	  tok

      | [] ->

	  (* The finite list has been exhausted. Here, two plausible behaviors
	     come to mind.

	     The first behavior consists in raising an exception. In that case,
	     we are creating a finite stream, and it is up to the parser to not
	     read past its end.

	     The second behavior consists in returning a designated token. In
	     that case, we are creating an infinite, eventually constant,
	     stream.

	     The choice between these two behaviors is somewhat arbitrary;
	     furthermore, in the second case, the choice of the designated
	     token is arbitrary as well. Here, we adopt the second behavior if
	     and only if the grammar has an EOF token, and we use EOF as the
	     designated token. Again, this is arbitrary, and could be changed
	     in the future. *)

	  match Terminal.eof with
	  | Some eof ->
	      eof
	  | None ->
	      raise EndOfStream

    in

    (* For now, return dummy positions. *)

    tok, Lexing.dummy_pos, Lexing.dummy_pos

(* --------------------------------------------------------------------------- *)

120 121 122 123 124 125 126
(* [start sentence] returns the start symbol that we should use to interpret
   the sentence [sentence]. *)

(* If a start symbol was explicitly provided as part of the sentence, we use
   it. Otherwise, we use the grammar's unique start symbol, if there is
   one. *)

127
let start poss ((nto, _) : sentence) : Nonterminal.t =
128 129 130 131 132 133
  match nto with
  | Some nt ->
      nt
  | None ->
      match ProductionMap.is_singleton Lr1.entry with
      | None ->
134
          Error.error poss
135 136 137 138 139 140 141 142 143
            "Because the grammar has multiple start symbols, each of the\n\
             sentences provided on the standard input channel must be of the\n\
             form: <start symbol>: <token>*"
      | Some (prod, _) ->
          match Production.classify prod with
          | Some nt ->
              nt
          | None ->
              assert false
144

145
(* --------------------------------------------------------------------------- *)
146

147
(* [interpret] interprets a sentence. *)
148

149
let interpret ((_, toks) as sentence) : unit =
150

151
  let nt = start [] sentence in
152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194

  (* Run the reference interpreter. This can produce a concrete syntax tree
     ([Some cst]), fail with a parser error ([None]), or fail with a lexer error
     ([EndOfStream]). *)

  (* In either case, we produce just one line of output, so it should be clear
     to the user which outcomes correspond to which sentences (should multiple
     sentences be supplied). *)

  begin try
    match
      MenhirLib.Convert.Simplified.traditional2revised
	(ReferenceInterpreter.interpret Settings.trace nt)
	(stream toks)
    with

    | Some cst ->

	(* Success. *)

	Printf.printf "ACCEPT";
	if Settings.interpret_show_cst then begin
	  print_newline();
	  Cst.show stdout cst
	end

    | None ->

	(* Parser failure. *)

	Printf.printf "REJECT"

  with EndOfStream ->

    (* Lexer failure. *)
    
    Printf.printf "OVERSHOOT"

  end;
  print_newline()

(* --------------------------------------------------------------------------- *)

195 196
(* [interpret_error_aux] interprets a sentence, expecting it to end in an
   error. Failure or success is reported via two continuations. *)
197

198 199
let interpret_error_aux poss ((_, terminals) as sentence) fail succeed =
  let nt = start poss sentence in
200
  let open ReferenceInterpreter in
201
  match check_error_path nt terminals with
202
  | OInputReadPastEnd ->
203
      fail "No syntax error occurs."
204
  | OInputNotFullyConsumed ->
205
      fail "A syntax error occurs before the last token is reached."
206
  | OUnexpectedAccept ->
207
      fail "No syntax error occurs; in fact, this input is accepted."
208 209
  | OK target ->
      succeed nt terminals target
210 211 212 213 214 215 216 217 218 219

(* --------------------------------------------------------------------------- *)

(* This default error message is produced by [--list-errors] when it creates a
   [.messages] file, and is recognized by [--compare-errors] when it compares
   two such files. *)

let default_message =
  "<YOUR SYNTAX ERROR MESSAGE HERE>\n"

220 221 222 223
(* [print_messages_auto] displays just the sentence and the auto-generated
   comments. [os'] may be [None], in which case the auto-generated comment
   is just a warning that this sentence does not end in an error. *)

224
let print_messages_auto (nt, sentence, otarget) : unit =
225 226
  (* Print the sentence, followed with auto-generated comments. *)
  print_string (print_sentence (Some nt, sentence));
227
  match otarget with
228 229 230 231 232 233
  | None ->
      Printf.printf
        "##\n\
         ## WARNING: This sentence does NOT end with a syntax error, as it should.\n\
         ##\n"
  | Some (s', spurious) ->
234
      Printf.printf
235 236 237 238
        "##\n\
         ## Ends in an error in state: %d.\n\
         ##\n\
         %s##\n"
239 240 241 242
        (Lr1.number s')
        (* [Lr0.print] or [Lr0.print_closure] could be used here. The latter
           could sometimes be helpful, but is usually intolerably verbose. *)
        (Lr0.print "## " (Lr1.state s'))
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
      ;
      if spurious <> [] then begin
        Printf.printf
          "## WARNING: This example involves spurious reductions.\n\
           ## This implies that, although the LR(1) items shown above provide an\n\
           ## accurate view of the past (what has been recognized so far), they\n\
           ## may provide an INCOMPLETE view of the future (what was expected next).\n"
        ;
        List.iter (fun prod ->
          Printf.printf
            "## Spurious reduction of production %s\n"
            (Production.print prod)
        ) spurious;
        Printf.printf "##\n"
      end
258

259
(* [print_messages_item] displays one data item. The item is of the form [nt,
260 261 262 263
   sentence, target], which means that beginning at the start symbol [nt], the
   sentence [sentence] ends in an error in the target state given by [target].
   [target] also contains information about which spurious reductions are
   performed at the end. The display obeys the [.messages] file format. *)
264

265
let print_messages_item (nt, sentence, target) : unit =
266
  (* Print the sentence, followed with auto-generated comments. *)
267
  print_messages_auto (nt, sentence, Some target);
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290
  (* Then, print a proposed error message, between two blank lines. *)
  Printf.printf "\n%s\n" default_message

(* --------------------------------------------------------------------------- *)

(* [write_messages runs] turns a list of runs into a new [.messages] file.
   Any manually-written comments are preserved. New auto-generated comments
   are produced. *)

let write_run : maybe_targeted_run -> unit =
  fun (sentences_or_comments, message) ->
    (* First, print every sentence and human comment. *)
    List.iter (fun sentence_or_comment ->
      match sentence_or_comment with
      | Sentence ((poss, ((_, toks) as sentence)), os') ->
          let nt = start poss sentence in
          (* Every sentence is followed with newly generated auto-comments. *)
          print_messages_auto (nt, toks, os')
      | Comment c ->
          print_string c
    ) sentences_or_comments;
  (* Then, print the error message, between two blank lines. *)
  Printf.printf "\n%s\n" message
291

292
(* --------------------------------------------------------------------------- *)
293

294 295 296 297 298
(* [interpret_error] interprets a sentence, expecting it to end in an error.
   Failure or success is reported on the standard output channel. This is
   used by [--interpret-error]. *)

let fail msg =
299
  Error.error [] msg
300

301 302
let succeed nt terminals target =
  print_messages_item (nt, terminals, target);
303 304 305 306 307 308 309
  exit 0

let interpret_error sentence =
  interpret_error_aux [] sentence fail succeed

(* --------------------------------------------------------------------------- *)

310 311 312 313
(* [target_sentence] interprets a (located) sentence, expecting it to end in
   an error, computes the state in which the error is obtained, and constructs
   a targeted sentence. *)

314
let target_sentence signal : located_sentence -> maybe_targeted_sentence =
315
  fun (poss, sentence) ->
316
    (poss, sentence),
317
    interpret_error_aux poss sentence
318 319 320 321 322 323 324 325 326
      (* failure: *)
      (fun msg ->
        signal poss (Printf.sprintf
          "This sentence does not end with a syntax error, as it should.\n%s"
          msg
        );
        None
      )
      (* success: *)
327
      (fun _nt _terminals target -> Some target)
328 329

let target_run_1 signal : run -> maybe_targeted_run =
330
  fun (sentences, message) ->
331
    List.map (or_comment_map (target_sentence signal)) sentences, message
332

333
let target_run_2 : maybe_targeted_run -> targeted_run =
334
  fun (sentences, message) ->
335 336
    let aux (x, y) = (x, Misc.unSome y) in
    List.map (or_comment_map aux) sentences, message
337 338 339

let target_runs : run list -> targeted_run list =
  fun runs ->
340
    (* Interpret all sentences, possibly displaying multiple errors. *)
341
    let runs = List.map (target_run_1 Error.signal) runs in
342
    (* Abort if an error occurred. *)
343
    if Error.errors() then exit 1;
344 345
    (* Remove the options introduced by the first phase above. *)
    let runs = List.map target_run_2 runs in
346
    runs
347

348
(* --------------------------------------------------------------------------- *)
349

350 351 352 353 354 355 356 357
(* [filter_run] filters out the comments in a run. *)

let filter_run : targeted_run -> filtered_targeted_run =
  fun (sentences, message) ->
    List.flatten (List.map unSentence sentences), message

(* --------------------------------------------------------------------------- *)

358 359
(* [setup()] returns a function [read] which reads one sentence from the
   standard input channel. *)
360

361
let setup () : unit -> sentence option =
362

363 364 365
  let open Lexing in
  let lexbuf = from_channel stdin in
  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = "(stdin)" };
366

367 368
  let read () =
    try
369
      SentenceParser.optional_sentence SentenceLexer.lex lexbuf
370 371 372
    with Parsing.Parse_error ->
      Error.error (Positions.lexbuf lexbuf) "Ill-formed input sentence."
  in
373

374 375 376 377 378 379
  read

(* --------------------------------------------------------------------------- *)

(* If [--interpret] is set, interpret the sentences found on the standard
   input channel, then stop, without generating a parser. *)
380

381 382 383 384 385 386 387
(* We read a series of sentences from the standard input channel. To allow
   interactive use, we interpret each sentence as soon as it is read. *)

let () =
  if Settings.interpret then
    let read = setup() in
    while true do
388 389
      match read() with
      | None ->
390
  	  exit 0
391
      | Some sentence ->
392 393
	  interpret sentence
    done
394

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410
(* --------------------------------------------------------------------------- *)

(* If [--interpret-error] is set, interpret one sentence found on the standard
   input channel, then stop, without generating a parser. *)

(* We read just one sentence, confirm that this sentence ends in an error, and
   (if that is the case) display the number of the state that is reached. *)

let () =
  if Settings.interpret_error then
    let read = setup() in
    match read() with
    | None ->
      exit 1 (* abnormal: no input *)
    | Some sentence ->
        interpret_error sentence (* never returns *)
411

412 413
(* --------------------------------------------------------------------------- *)

414 415 416 417 418 419 420 421 422 423 424 425
(* Reading a [.messages] file. *)

let read_messages filename : run list =
  (* Read and segment the file. *)
  let segments : (string * Lexing.lexbuf) list = Segment.segment filename in
  (* Process the segments, two by two. We expect one segment to contain
     a non-empty series of sentences, and the next segment to contain
     free-form text. *)
  let rec loop accu segments =
    match segments with
    | [] ->
        List.rev accu
426 427
    | (_, lexbuf) :: segments ->
        (* Read a series of located sentences. *)
428 429
        match SentenceParser.entry SentenceLexer.lex lexbuf with
        | exception Parsing.Parse_error ->
430
            Error.error
431
              (Positions.one (Lexing.lexeme_start_p lexbuf))
432
              "Ill-formed sentence."
433
        | sentences ->
434 435 436 437 438 439 440 441
            (* Read a segment of text. *)
            match segments with
            | [] ->
              Error.error
                (Positions.one (Lexing.lexeme_end_p lexbuf))
                "Syntax error: missing a final message. I may be desynchronized."
            | (text, _) :: segments ->
                loop ((sentences, text) :: accu) segments
442
  in
443
  loop [] segments
444 445 446

(* --------------------------------------------------------------------------- *)

447
(* [message_table] converts a list of targeted runs to a table (a mapping) of
448 449
   states to located sentences and messages. Optionally, it can detect that
   two sentences lead to the same state, and report an error. *)
450

451
let message_table (detect_redundancy : bool) (runs : filtered_targeted_run list)
452
  : (located_sentence * message) Lr1.NodeMap.t =
453 454

  let table =
455
    List.fold_left (fun table (sentences_and_states, message) ->
456 457
      List.fold_left (fun table (sentence2, target) ->
        let s = target2state target in
458
        match Lr1.NodeMap.find s table with
459
        | sentence1, _ ->
460 461 462 463 464 465 466
            if detect_redundancy then
              Error.signal (fst sentence1 @ fst sentence2)
                (Printf.sprintf
                   "Redundancy: these sentences both cause an error in state %d."
                   (Lr1.number s));
            table
        | exception Not_found ->
467
            Lr1.NodeMap.add s (sentence2, message) table
468 469 470 471 472 473 474 475 476 477 478 479
      ) table sentences_and_states
    ) Lr1.NodeMap.empty runs
  in
  if Error.errors() then exit 1;
  table

(* --------------------------------------------------------------------------- *)

(* [compile_runs] converts a list of targeted runs to OCaml code that encodes
   a mapping of state numbers to error messages. The code is sent to the
   standard output channel. *)

480
let compile_runs filename (runs : filtered_targeted_run list) : unit =
481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497

  (* We wish to produce a function that maps a state number to a message.
     By convention, we call this function [message]. *)

  let name = "message" in

  let open IL in
  let open CodeBits in
  let default = {
    branchpat  = PWildcard;
    branchbody = eraisenotfound
  (* The default branch raises an exception, which can be caught by
     the user, who can then produce a generic error message. *)
  } in
  let branches =
    List.fold_left (fun branches (sentences_and_states, message) ->
      (* Create an or-pattern for these states. *)
498 499
      let states = List.map (fun (_, target) ->
        let s = target2state target in
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
        pint (Lr1.number s)
      ) sentences_and_states in
      (* Map all these states to this message. *)
      { branchpat = POr states;
        branchbody = EStringConst message } :: branches
    ) [ default ] runs
  in
  let messagedef = {
    valpublic = true;
    valpat = PVar name;
    valval = EFun ([ PVar "s" ], EMatch (EVar "s", branches))
  } in
  let program = [
    SIComment (Printf.sprintf
      "This file was auto-generated based on \"%s\"." filename);
    SIComment (Printf.sprintf
      "Please note that the function [%s] can raise [Not_found]." name);
    SIValDefs (false,
      [ messagedef ]);
  ] in

  (* Write this program to the standard output channel. *)

  let module P = Printer.Make (struct
    let f = stdout
    let locate_stretches = None
  end) in
  P.program program

(* --------------------------------------------------------------------------- *)

531 532 533 534 535
(* If [--compile-errors <filename>] is set, compile the error message
   descriptions found in file [filename] down to OCaml code, then stop. *)

let () =
  Settings.compile_errors |> Option.iter (fun filename ->
536

537 538
    (* Read the file. *)
    let runs = read_messages filename in
539

540 541
    (* Convert every sentence to a state number. We signal an error if a
       sentence does not end in an error, as expected. *)
542
    let runs = target_runs runs in
543

544 545 546
    (* Remove comments. *)
    let runs = List.map filter_run runs in

547 548
    (* Build a mapping of states to located sentences. This allows us to
       detect if two sentences lead to the same state. *)
549
    let _ = message_table true runs in
550

551 552 553 554 555 556
    (* In principle, we would like to check whether this set of sentences is
       complete (i.e., covers all states where an error can arise), but this
       may be costly -- it requires running [LRijkstra]. Instead, we offer a
       separate facility for comparing two [.messages] files, one of which can
       be produced via [--list-errors]. This can be used to ensure
       completeness. *)
POTTIER Francois's avatar
POTTIER Francois committed
557

558 559 560
    (* Now, compile this information down to OCaml code. We wish to
       produce a function that maps a state number to a message. By
       convention, we call this function [message]. *)
561
    compile_runs filename runs;
562

563 564 565
    exit 0
  )

566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
(* --------------------------------------------------------------------------- *)

(* If two [--compare-errors <filename>] directives are provided, compare the
   two message descriptions files, and stop. We wish to make sure that every
   state that appears on the left-hand side appears on the right-hand side as
   well. *)

let () =
  Settings.compare_errors |> Option.iter (fun (filename1, filename2) ->

    (* Read and convert both files, as above. *)
    let runs1 = read_messages filename1
    and runs2 = read_messages filename2 in
    let runs1 = target_runs runs1
    and runs2 = target_runs runs2 in (* here, it would be OK to ignore errors *)
581 582
    let runs1 = List.map filter_run runs1
    and runs2 = List.map filter_run runs2 in
583 584 585 586 587 588 589 590 591 592 593 594 595 596 597
    let table1 = message_table false runs1
    and table2 = message_table false runs2 in
    
    (* Check that the domain of [table1] is a subset of the domain of [table2]. *)
    table1 |> Lr1.NodeMap.iter (fun s ((poss1, _), _) ->
      if not (Lr1.NodeMap.mem s table2) then
        Error.signal poss1 (Printf.sprintf
          "This sentence leads to an error in state %d.\n\
           No sentence that leads to this state exists in \"%s\"."
          (Lr1.number s) filename2
        )
    );

    (* Check that [table1] is a subset of [table2], that is, for every state
       [s] in the domain of [table1], [s] is mapped by [table1] and [table2]
598 599 600 601 602
       to the same error message. As an exception, if the message found in
       [table1] is the default message, then no comparison takes place. This
       allows using [--list-errors] and [--compare-errors] in conjunction to
       ensure that a [.messages] file is complete, without seeing warnings
       about different messages. *)
603
    table1 |> Lr1.NodeMap.iter (fun s ((poss1, _), message1) ->
604 605 606 607 608 609 610 611 612 613 614
      if message1 <> default_message then
        try
          let (poss2, _), message2 = Lr1.NodeMap.find s table2 in
          if message1 <> message2 then
            Error.warning (poss1 @ poss2) (Printf.sprintf
              "These sentences lead to an error in state %d.\n\
               The corresponding messages in \"%s\" and \"%s\" differ."
              (Lr1.number s) filename1 filename2
            )
        with Not_found ->
          ()
615 616 617 618 619 620 621
    );

    if Error.errors() then exit 1;
    exit 0

  )

622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654
(* --------------------------------------------------------------------------- *)

(* If [--update-errors <filename>] is set, update the error message
   descriptions found in file [filename]. The idea is to re-generate
   the auto-comments, which are marked with ##, while leaving the
   rest untouched. *)

let () =
  Settings.update_errors |> Option.iter (fun filename ->

    (* Read the file. *)
    let runs = read_messages filename in

    (* Convert every sentence to a state number. Warn, but do not
       fail, if a sentence does not end in an error, as it should. *)
    let runs = List.map (target_run_1 Error.warning) runs in

    (* We might wish to detect if two sentences lead to the same state. We
       might also wish to detect if this set of sentences is incomplete,
       and complete it automatically. However, the first task is carried
       out by [--compile-errors] already, and the second task is carried
       out by [--list-errors] and [--compare-errors] together. For now,
       let's try and keep things as simple as possible. The task of
       [--update-errors] should be to update the auto-generated comments,
       without failing, and without adding or removing sentences. *)

    (* Now, write a new [.messages] to the standard output channel, with
       new auto-generated comments. *)
    List.iter write_run runs;

    exit 0
  )