Source file parsers.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
open UtilsLib
open AcgData.Environment
open AcgData.Signature
open AcgData.Acg_lexicon

(* A short name for the incremental parser API. *)

let tok_to_string = function
  | Data_parser.EOI -> "EOI"
  | Data_parser.LPAREN _ -> "LPAREN"
  | Data_parser.RPAREN _ -> "RPAREN"
  | Data_parser.RSQBRACKET _ -> "RSQBRACKET"
  | Data_parser.LSQBRACKET _ -> "LSQBRACKET"
  | Data_parser.SIG_OPEN _ -> "SIG_OPEN"
  | Data_parser.LEX_OPEN _ -> "LEX_OPEN"
  | Data_parser.NL_LEX_OPEN _ -> "NL_LEX_OPEN"
  | Data_parser.END_OF_DEC _ -> "END_OF_DEC"
  | Data_parser.IDENT (s, _) -> Printf.sprintf "IDENT (%s)" s
  | Data_parser.COLON _ -> "COLON"
  | Data_parser.EQUAL _ -> "EQUAL"
  | Data_parser.SEMICOLON _ -> "SEMICOLON"
  | Data_parser.COMPOSE _ -> "COMPOSE"
  | Data_parser.SYMBOL (s, _) -> Printf.sprintf "SYMBOL (%s)" s
  | Data_parser.COMMA _ -> "COMMA"
  | Data_parser.TYPE _ -> "TYPE"
  | Data_parser.PREFIX _ -> "PREFIX"
  | Data_parser.INFIX _ -> "INFIX"
  | Data_parser.BINDER _ -> "BINDER"
  | Data_parser.COLON_EQUAL _ -> "COLON_EQUAL"
  | Data_parser.LAMBDA _ -> "LAMBDA"
  | Data_parser.LAMBDA0 _ -> "LAMBDA0"
  | Data_parser.DOT _ -> "DOT"
  | Data_parser.ARROW _ -> "ARROW"
  | Data_parser.LIN_ARROW _ -> "LIN_ARROW"
  [@@warning "-unused-value-declaration"]

module I = Data_parser.MenhirInterpreter

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

(* The above loop is shown for explanatory purposes, but can in fact be
   replaced with the following code, which exploits the functions
   [lexer_lexbuf_to_supplier] and [loop_handle] offered by Menhir. *)

let succeed
    (data : ?overwrite:bool -> no_magic:bool -> filename:string -> Environment.t -> Environment.t)
    =
  (* The parser has succeeded and produced a semantic value. *)
  data

let fail lexbuf c =
  (* The parser has suspended itself because of a syntax error. Stop. *)
  match c with
  | I.HandlingError env ->
    let loc = Sedlexing.lexing_positions lexbuf in
    let current_state_num = I.current_state_number env in
        Errors.(ParsingErrors.emit (Parsing_l.MenhirError current_state_num) ~loc)
  | _ -> failwith "Should not happen. Always fails with a HandlingError"

let core_supplier lexbuf =
  let () = Data_lexer.reset () in
  fun () ->
    let token = Data_lexer.lex lexbuf in
    let startp, endp = Sedlexing.lexing_positions lexbuf in
    (token, startp, endp)

let supplier = core_supplier

let parse_data ?(overwrite = false) ?output ~no_magic lexbuf env =
  let (p, _) = Sedlexing.lexing_positions lexbuf in
  let filename = p.Lexing.pos_fname in
  let () = Logs.app (fun m -> m "Parsing \"%s\"..." filename) in
  let starting_parse_time = Timer.top () in
  let e =
    (I.loop_handle succeed (fail lexbuf) (supplier lexbuf)
       (Data_parser.Incremental.main
          (fst (Sedlexing.lexing_positions lexbuf))))
      ~overwrite ~no_magic ~filename env
  in
  let ending_parse_time = Timer.top () in
  let () =
    Logs.app (fun m ->
        m "Done (%a)."
          Timer.diff
          (ending_parse_time, starting_parse_time))
  in
  let () =
    match output with
    | None -> ()
    | Some fmt ->
        Environment.iter
          (function
            | Environment.Signature sg ->
                Format.fprintf fmt "@[<2>@[%a]@]@]" Data_Signature.pp sg
            | Environment.Lexicon lex ->
                Format.fprintf fmt "@[<2>@[%a]@]@]" Data_Lexicon.pp lex)
          e
  in
  Some e

let parse_type lexbuf sg =
  try
    let abs_type =
      I.loop_handle
        (fun x -> x)
        (fail lexbuf) (supplier lexbuf)
        (Data_parser.Incremental.type_alone
           (fst (Sedlexing.lexing_positions lexbuf)))
        sg
    in
    Some abs_type
  with
  (* | AcgData.Old_error.Error er ->
      let () = pp_error ~color ?parsing_context er t in
      None *)
  | End_of_file -> None

let parse_term lexbuf sg =
  try
    let abs_term, abs_type =
      I.loop_handle
        (fun x -> x)
        (fail lexbuf) (supplier lexbuf)
        (Data_parser.Incremental.term_alone
           (fst (Sedlexing.lexing_positions lexbuf)))
        sg
    in
    Some (abs_term, abs_type)
  with
  (* | AcgData.Old_error.Error er ->
      let () = pp_error ~color ?parsing_context er t in
      None *)
  | End_of_file -> None

let parse_sig_entry lexbuf sg =
  try
    Some
      (I.loop (supplier lexbuf)
         (Data_parser.Incremental.sig_entry_eoi
            (fst (Sedlexing.lexing_positions lexbuf)))
         sg)
  with
  (* | AcgData.Old_error.Error er ->
      let () = pp_error ~color er t in
      None *)
  | End_of_file -> None

let parse_lex_entry lexbuf lex =
  try
    Some
      (I.loop (supplier lexbuf)
         (Data_parser.Incremental.lex_entry_eoi
            (fst (Sedlexing.lexing_positions lexbuf)))
         lex)
  with
  (* | AcgData.Old_error.Error er ->
      let () = pp_error ~color er t in
      None *)
  | End_of_file -> None