package merlin-lib

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file mreader_parser.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
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
195
196
197
198
199
200
(* {{{ 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
OCaml

Innovation. Community. Security.