Source file mreader_parser.ml

(* {{{ COPYING *(

  This file is part of Merlin, an helper for ocaml editors

  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
                             Thomas Refis  <refis.thomas(_)gmail.com>
                             Simon Castellan  <simon.castellan(_)iuwt.fr>

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  The Software is provided "as is", without warranty of any kind, express or
  implied, including but not limited to the warranties of merchantability,
  fitness for a particular purpose and noninfringement. In no event shall
  the authors or copyright holders be liable for any claim, damages or other
  liability, whether in an action of contract, tort or otherwise, arising
  from, out of or in connection with the software or the use or other dealings
  in the Software.

)* }}} *)

open Std

module I = Parser_raw.MenhirInterpreter

type kind =
  | ML
  | MLI
  (*| MLL | MLY*)

module Dump = struct
  let symbol () = Parser_printer.print_symbol
end

module R = Mreader_recover.Make
    (I)
    (struct
      include Parser_recover

      let default_value loc x =
        Default.default_loc := loc;
        default_value x

      let guide (type a) : a I.symbol -> bool = function
        | I.T I.T_BEGIN -> true
        | _ -> false

      let token_of_terminal = Parser_printer.token_of_terminal

      let nullable = Parser_explain.nullable
    end)
   (Dump)

type 'a step =
  | Correct of 'a I.checkpoint
  | Recovering of 'a R.candidates

type tree = [
  | `Interface of Parsetree.signature
  | `Implementation of Parsetree.structure
]

type steps =[
  | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list
  | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list
]

type t = {
  kind: kind;
  tree: tree;
  steps: steps;
  errors: exn list;
  lexer: Mreader_lexer.t;
}

let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos)

let errors_ref = ref []

let resume_parse =
  let rec normal acc tokens = function
    | I.InputNeeded env as checkpoint ->
      let token, tokens = match tokens with
        | token :: tokens -> token, tokens
        | [] -> eof_token, []
      in
      check_for_error acc token tokens env (I.offer checkpoint token)

    | I.Shifting (_,env,_) | I.AboutToReduce (env,_) as checkpoint ->
      begin match I.resume checkpoint with
        | checkpoint' -> normal acc tokens checkpoint'
        | exception exn ->
          Msupport.raise_error exn;
          let token = match acc with
            | [] -> assert false
            (* Parser raised error before parsing anything *)
            | (_, token) :: _ -> token
          in
          enter_error acc token tokens env
      end

    | I.Accepted v -> acc, v

    | I.Rejected | I.HandlingError _ ->
      assert false

  and check_for_error acc token tokens env = function
    | I.HandlingError _ ->
      enter_error acc token tokens env

    | I.Shifting _ | I.AboutToReduce _ as checkpoint ->
      begin match I.resume checkpoint with
        | checkpoint' -> check_for_error acc token tokens env checkpoint'
        | exception exn ->
          Msupport.raise_error exn;
          enter_error acc token tokens env
      end

    | checkpoint ->
      normal ((Correct checkpoint, token) :: acc) tokens checkpoint

  and enter_error acc token tokens env =
    let candidates = R.generate env in
    let explanation =
      Mreader_explain.explain env token
        candidates.R.popped candidates.R.shifted
    in
    errors_ref := Mreader_explain.Syntax_explanation explanation :: !errors_ref;
    recover acc (token :: tokens) candidates

  and recover acc tokens candidates =
    let token, tokens = match tokens with
      | token :: tokens -> token, tokens
      | [] -> eof_token, []
    in
    let acc' = ((Recovering candidates, token) :: acc) in
    match R.attempt candidates token with
    | `Fail ->
      if tokens = [] then
        match candidates.R.final with
        | None -> failwith "Empty file"
        | Some v -> acc', v
      else
        recover acc tokens candidates
    | `Accept v -> acc', v
    | `Ok (checkpoint, _) ->
      normal ((Correct checkpoint, token) :: acc) tokens checkpoint
  in
  fun acc tokens -> function
  | Correct checkpoint -> normal acc tokens checkpoint
  | Recovering candidates -> recover acc tokens candidates

let seek_step steps tokens =
  let rec aux acc = function
    | (step :: steps), (token :: tokens) when snd step = token ->
      aux (step :: acc) (steps, tokens)
    | _, tokens -> acc, tokens
  in
  aux [] (steps, tokens)

let parse initial steps tokens initial_pos =
  let acc, tokens = seek_step steps tokens in
  let step =
    match acc with
    | (step, _) :: _ -> step
    | [] -> Correct (initial initial_pos)
  in
  let acc, result = resume_parse acc tokens step in
  List.rev acc, result

let run_parser warnings lexer previous kind =
  Msupport.catch_errors warnings errors_ref @@ fun () ->
  let tokens = Mreader_lexer.tokens lexer in
  let initial_pos = Mreader_lexer.initial_position lexer in
  match kind with
  | ML  ->
    let steps = match previous with
      | `Structure steps -> steps
      | _ -> []
    in
    let steps, result =
      let state = Parser_raw.Incremental.implementation in
      parse state steps tokens initial_pos in
    `Structure steps, `Implementation result
  | MLI ->
    let steps = match previous with
      | `Signature steps -> steps
      | _ -> []
    in
    let steps, result =
      let state = Parser_raw.Incremental.interface in
      parse state steps tokens initial_pos in
    `Signature steps, `Interface result

let make warnings lexer kind =
  errors_ref := [];
  let steps, tree = run_parser warnings lexer `None kind in
  let errors = !errors_ref in
  errors_ref := [];
  {kind; steps; tree; errors; lexer}

let result t = t.tree

let errors t = t.errors