Source

meta_conv / ocaml / ocaml.ml

Full commit
open Meta_conv

type t = 
  | Bool of bool
  | Int31 of int
  | Int63 of int64
  | Int32 of int32
  | Int64 of int64
  | Nativeint32 of int32
  | Nativeint64 of int64
  | Float of float
  | Char of char
  | String of string
  | List of t list
  | Array of t list
  | Variant of string * t list
  | Poly_variant of string * t list (* Note that it is different from OCaml implementation *)
  | Record of (string * t) list
  | Object of (string * t) list
  | Tuple of t list
  | Unit

type ocaml = t

open Format

let format_sprintf fmt =
  let buf = Buffer.create 100 in
  let ppf = formatter_of_buffer buf in
  kfprintf (fun ppf -> pp_print_flush ppf (); Buffer.contents buf) ppf fmt

let rec format_list (sep : (unit, formatter, unit) format)  f ppf = function
  | [] -> ()
  | [x] -> f ppf x
  | x::xs -> 
      fprintf ppf "@[%a@]%t%a" 
	f x
	(fun ppf -> fprintf ppf sep)
	(format_list sep f) xs

let format ?(no_poly=false) ?(raw_string=false) ppf v = 
  let rec format ppf = function
    | Bool b -> fprintf ppf "%b" b
    | Int31 i -> fprintf ppf "%d" i
    | Int63 i -> fprintf ppf "%Ld" i
    | Int32 i -> fprintf ppf "%ldl" i
    | Int64 i -> fprintf ppf "%LdL" i
    | Nativeint32 i -> fprintf ppf "%ldn" i
    | Nativeint64 i -> fprintf ppf "%Ldn" i
    | Float f -> fprintf ppf "%F" f
    | Char c -> fprintf ppf "%C" c
    | String s -> if raw_string then fprintf ppf "\"%s\"" s else fprintf ppf "%S" s
    | List [] -> fprintf ppf "[]"
    | List ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
    | Array ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
    | Variant ("::", [hd;tl]) -> fprintf ppf "@[<2>(%a@ :: %a)@]" format hd format tl
    | Variant (tag, []) -> fprintf ppf "%s" tag
    | Variant (tag, [t]) -> fprintf ppf "@[<2>%s@ @[%a@]@]" tag format t
    | Variant (tag, ts) -> fprintf ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
    | Poly_variant (tag, [])  when no_poly -> fprintf ppf "%s" tag
    | Poly_variant (tag, [t]) when no_poly -> fprintf ppf "@[<2>%s@ @[%a@]@]" tag format t
    | Poly_variant (tag, ts)  when no_poly -> fprintf ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
    | Poly_variant (tag, []) -> fprintf ppf "`%s" tag
    | Poly_variant (tag, [t]) -> fprintf ppf "@[<2>`%s@ @[%a@]@]" tag format t
    | Poly_variant (tag, ts) -> fprintf ppf "@[<2>`%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
    | Record fields -> fprintf ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (f, v) -> fprintf ppf "%s= %a" f format v)) fields
    | Object fields when no_poly -> fprintf ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (f, v) -> fprintf ppf "%s= %a" f format v)) fields
    | Object fields -> fprintf ppf "@[@[<2>object@,@[%a@]@]@,end@]" (format_list "@ " (fun ppf (f, v) -> fprintf ppf "method %s= %a" f format v)) fields
    | Tuple ts -> fprintf ppf "(@[%a@])" (format_list ",@ " format) ts
    | Unit -> fprintf ppf "()"
  in
  format ppf v

let format_with ?no_poly ?raw_string f ppf v = format ?no_poly ?raw_string ppf (f v)

(** { 6 Parsing by compiler-libs } *)

module Parser = struct
  open Parsetree
  open Longident
  open Asttypes

  type error = [ `Invalid_construct of Location.t
               | `Lexer of Location.t * Lexer.error
               | `Parser of Syntaxerr.error
               | `Exn of exn ]

  exception Error of error

  let loc_of_error = function
    | `Invalid_construct loc -> loc
    | `Lexer (loc, _) -> loc
    | `Parser e ->
        let open Syntaxerr in
        begin match e with
        | Unclosed (loc, _, _, _) -> loc
        | Applicative_path loc -> loc
        | Variable_in_scope (loc, _) -> loc
        | Other loc -> loc
        end
    | `Exn _ -> Location.none

  let format_error ppf e = 
    let open Format in
    let loc = loc_of_error e in
    if not (loc = Location.none) then fprintf ppf "%a: " Location.print loc;
    match e with
    | `Invalid_construct _ -> fprintf ppf "invalid construct for simple ocaml value"
    | `Exn (Failure s) -> fprintf ppf "failure: %s" s
    | `Exn exn  -> fprintf ppf "exn: %s" (Printexc.to_string exn)
    | `Lexer (_loc, e)  -> fprintf ppf "lexer error: %a"  Lexer.report_error e
    | `Parser e -> fprintf ppf "parser error: %a" Syntaxerr.report_error e

  let () = Printexc.register_printer (function
    | Error e -> Some (format_sprintf "%a" format_error e)
    | _ -> None)

  let exn ex = raise (Error (`Exn ex))
  let invalid loc = raise (Error (`Invalid_construct loc))

  (* We simply discard module paths *)
  let strip loc = function
    | Lident s -> s
    | Ldot (_, s) -> s
    | Lapply _ -> invalid loc

  let rec structure sitems = List.map structure_item sitems
    
  and structure_item s = 
    match s.pstr_desc with
    | Pstr_eval e -> expression e
    (* | Pstr_value of rec_flag * (pattern * expression) list *)
    | _ -> invalid s.pstr_loc

  and expression e =
    match e.pexp_desc with
    | Pexp_constant c -> constant c
    | Pexp_tuple es -> tuple es
    | Pexp_construct ({txt; _}, argopt, _) -> construct e.pexp_loc txt argopt
    | Pexp_variant (l, expopt) -> variant l expopt
    | Pexp_record (fields, None) -> record fields
    | Pexp_array es -> array es
    | Pexp_object class_str ->
        (* Ignores class_str.pcstr_pat *)
        object_ class_str.pcstr_fields
    | _ -> invalid e.pexp_loc

  and constant = function
    | Const_char c -> Char c
    | Const_string s -> String s
    | Const_float s -> Float (float_of_string s)
    | Const_int32 i32 -> Int32 i32
    | Const_int64 i64 -> Int64 i64
    (* Arch dependent int is coerced to int64 *)
    | Const_int n -> Int63 (Int64.of_int n)
    | Const_nativeint ni -> Nativeint64 (Int64.of_nativeint ni)

  and tuple es = Tuple (List.map expression es)
  and array es = Array (List.map expression es)

  and variant l = function
    | None -> Poly_variant (l, [])
    | Some {pexp_desc= Pexp_tuple es; _} -> Poly_variant (l, List.map expression es)
    | Some e -> Poly_variant (l, [expression e])

  and record fields =
    Record (List.map (fun ({txt = txt; loc}, e) ->
      let e = expression e in
      strip loc txt, e) fields)

  and object_ fields =
    Object (List.map (fun { pcf_desc; pcf_loc } -> match pcf_desc with
    | Pcf_meth ({txt; _}, _, _, e) -> txt, expression e
    | _ -> invalid pcf_loc) fields)

  and construct loc lident argopt =
    let name = strip loc lident in
    match argopt with
    | None -> Variant (name, [])
    | Some {pexp_desc= Pexp_tuple es; _} -> Variant (name, List.map expression es)
    | Some e -> Variant (name, [expression e])

  let from_lexbuf lexbuf = 
    try
      Lexer.init (); (* not re-entrant *)
      let str = Parser.implementation Lexer.token lexbuf in
      structure str
    with
    | (Error _ as exn) -> raise exn
    | Lexer.Error (e, loc) -> raise (Error (`Lexer (loc, e)))
    | Syntaxerr.Error e -> raise (Error (`Parser e))
    | e -> exn e

  let from f d = from_lexbuf (f d)
  let from_channel  = from Lexing.from_channel
  let from_string   = from Lexing.from_string
  let from_function = from Lexing.from_function
end

type load_error = [ `Conv of t Meta_conv.Error.t
                  | `Exn of exn
                  | `Invalid_construct of Location.t
                  | `Lexer of Location.t * Lexer.error
                  | `Parser of Syntaxerr.error ]

let format_load_error ppf = function
  | `Conv e -> Meta_conv.Error.format (format ~no_poly:false ~raw_string:false) ppf e
  | (#Parser.error as e) -> Parser.format_error ppf e

exception Load_error of load_error

let () = Printexc.register_printer (function
  | Load_error e -> Some (format_sprintf "%a" format_load_error e)
  | _ -> None)

let load_with decoder path =
  try 
    let ic = open_in path in
    try
      let res = Result.map decoder (Parser.from_channel ic) in
      close_in ic;
      match res with
      | `Ok v -> `Ok v
      | `Error e -> `Error (`Conv e)
    with
    | Parser.Error (#Parser.error as e) -> close_in ic; `Error e
  with
  | exn -> `Error (`Exn exn)

let load_with_exn decoder path =
  match load_with decoder path with
  | `Ok v -> v
  | `Error e -> raise (Load_error e)

let save_with encoder ~perm ?no_poly path ts = 
  let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] perm path in
  try
    (* Double semis are reqiured to parse back by [Parser.implementation] *)
    let ppf = Format.formatter_of_out_channel oc in
    List.iter (fun t -> 
      Format.fprintf ppf "%a;;@." (format_with ?no_poly encoder) t;
    ) ts;
    close_out oc
  with
  | e -> 
      close_out oc;
      raise e