Source file parsers.ml

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