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 "-32"]

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"
  | exception Not_found ->
    let loc = Sedlexing.lexing_positions lexbuf in
    Errors.(ParsingErrors.emit Parsing_l.Other ~loc)

let core_supplier lexbuf () =
  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

  (* with
  | Utils.No_file (f, msg) ->
      let e =
        AcgData.Old_error.System_error
          (Printf.sprintf "No such file \"%s\" in %s" f msg)
      in
      let () =
        Logs.err (fun m -> m "%s" (AcgData.Old_error.error_msg e filename))
      in
      None
  | Sys_error s ->
      let e = AcgData.Old_error.System_error s in
      let () =
        Logs.err (fun m -> m "%s" (AcgData.Old_error.error_msg e filename))
      in
      None
  | AcgData.Old_error.Error e ->
      let () =
        Logs.err (fun m -> m "%s" (AcgData.Old_error.error_msg e filename))
      in
      None *)

(* let pp_error ?parsing_context ~color er t =
  let () = Utils.sformat "@." in
  let _ = Format.flush_str_formatter () in
  let s, e = AcgData.Old_error.get_loc_error er in
  let s', e' =
    (s.Lexing.pos_cnum - s.Lexing.pos_bol, e.Lexing.pos_cnum - e.Lexing.pos_bol)
  in
  let t_init = String.sub t 0 s' in
  let t_error_wo_color = String.sub t s' (e' - s') in
  let t_error =
    match color with
    | true -> Utils.red t_error_wo_color
    | false -> t_error_wo_color
  in
  let end_start_index = s' + (e' - s') in
  let t_end =
    String.sub t end_start_index (String.length t - end_start_index)
  in
  let () = Logs.err (fun m -> m "%s%s%s" t_init t_error t_end) in
  match parsing_context with
  | None -> Logs.err (fun m -> m "%s" (AcgData.Old_error.error_msg er "stdin"))
  | Some (file, (p1, _p2)) ->
      let new_er_pos = Lexing.(p1, { p1 with pos_cnum = e' + p1.pos_cnum }) in
      (*     let new_er_pos = (p1,p2) in *)
      let new_er = AcgData.Old_error.change_loc er new_er_pos in
      Logs.err (fun m -> m "%s" (AcgData.Old_error.error_msg new_er file)) *)

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