qsp_parser/lib/qparser/analyzer.ml

type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }

(** 
    Run the QSP parser and apply the analyzer over it.

    See [syntax/S]
 *)
let rec parse :
    type a context.
    (module Qsp_syntax.S.Analyzer
       with type Location.t = a
        and type context = context) ->
    Lexbuf.t ->
    context ->
    (a result, Qsp_syntax.Report.t) Result.t =
 fun (module S : Qsp_syntax.S.Analyzer
       with type Location.t = a
        and type context = context) ->
  let module Parser = Parser.Make (S) in
  let module IncrementalParser =
    Interpreter.Interpreter (Parser.MenhirInterpreter) in
  fun l context ->
    let lexer = Lexbuf.tokenize Lexer.main l in

    let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in

    (* Firslty, check if we are able to read the whole syntax from the source *)
    let evaluation =
      try IncrementalParser.of_lexbuf lexer l init with
      | Lexer.LexError message ->
          let start_pos, end_pos = Lexbuf.positions l in
          let err =
            IncrementalParser.
              { code = Interpreter.Custom message; start_pos; end_pos }
          in
          Error err
      | Lexer.UnclosedQuote | Lex_state.Out_of_context ->
          let start_pos, end_pos = Lexbuf.positions l in
          let err =
            IncrementalParser.
              {
                code = Interpreter.Custom "Unclosed string";
                start_pos;
                end_pos;
              }
          in
          Error err
    in

    (* Then evaluate the result *)
    match (evaluation, Lexbuf.is_recovery l) with
    | Ok r, _ ->
        (* We have been able to read the syntax, apply the checkers over the
           Tree *)
        let content = r context in
        Ok { content; report = S.Location.v content }
    | _, true ->
        (* This pattern can occur after recovering from an error. The
           application attempt to start from a clean state in the next
           location, but may fail to detect the correct position. If so, we
           just start again until we hook the next location *)
        parse (module S) l context
    | Error e, _ ->
        let message =
          match e.IncrementalParser.code with
          | Interpreter.UnrecoverableError -> "UnrecoverableError"
          | Interpreter.InvalidSyntax -> "Invalid Syntax"
          | Interpreter.Custom msg -> msg
          | Interpreter.MenhirCode c ->
              let message_content =
                try Parser_messages.message c
                with Not_found ->
                  String.concat "" [ "(Error code "; string_of_int c; ")" ]
              in
              String.concat "" [ String.trim message_content ]
        in

        let report = Qsp_syntax.Report.error (e.start_pos, e.end_pos) message in
        (* Rollback the buffer from the latest errror before discarding until
           the end of the location. This ensure we will read the marker
           for the end location in the case the error was actually in
           this line itsef.

           Example :

            # location
            <ERROR HERE>

            ! ------- a
            --- location ---------------------------------
        *)
        Lexbuf.rollback l;

        (* Discard the remaining file to read. The parser is now in a blank
           state, it does not make sense to keep feeding it with the new
           tokens. *)
        let () = try Lexer.discard l with _ -> () in

        Error report