Source

meta_conv / ocaml / ocaml.ml

Full commit
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 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 = Location.t * [ `Invalid_construct | `Exn of exn ]
  exception Error of error

  let format_sprintf fmt = Format.(
    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 show_error (loc, desc) = 
    let desc = match desc with
      | `Invalid_construct -> "invalid construct for simple ocaml value"
      | `Exn (Failure s) -> "failure: " ^ s
      | `Exn exn ->"exn: " ^  Printexc.to_string exn
    in
    if loc = Location.none then desc
    else format_sprintf "%a: %s" Location.print loc desc

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

  (* 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
    | e -> exn Location.none 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

let load_with decoder_exn path = 
  let ic = open_in path in
  try
    let res = List.map decoder_exn (Parser.from_channel ic) in
    close_in ic;
    res
  with
  | e ->
      close_in ic;
      raise 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
    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