Source file xhelper.ml

(* PPX related tools *)

open Ppxlib.Ast
open Ppxlib.Ast_helper
open Utils

module XLongident = struct
  open Longident
  open Format

  let ($.) l s = Ldot(l,s)

  (* [Pprintast.longident] is not exposed in OCaml 4.05.0 *)
  let rec format ppf = function
    | Lident n -> pp_print_string ppf n
    | Ldot (p, name) -> fprintf ppf "%a.%s" format p name
    | Lapply (p1, p2) -> fprintf ppf "%a(%a)" format p1 format p2

  let to_string l = ksprintf (fun x -> x) "%a" format l

  let parse = Ppxlib.Longident.parse
end

module XIdent = struct
  open Format

  let format ppf id = pp_print_string ppf (Ident.name id)
  let format_verbose = Ident.print_with_scope
end

module XPath = struct
  open Path
  open Format

  let rec format ppf = function
    | Pident id -> XIdent.format ppf id
    | Pdot (p, name) -> fprintf ppf "%a.%s" format p name
    | Papply (p1, p2) -> fprintf ppf "%a(%a)" format p1 format p2

  let rec format_verbose ppf = function
    | Pident id -> XIdent.format_verbose ppf id
    | Pdot (p, name) -> fprintf ppf "%a.%s" format_verbose p name
    | Papply (p1, p2) -> fprintf ppf "%a(%a)" format_verbose p1 format_verbose p2

  let to_string l = ksprintf (fun x -> x) "%a" format l
end

module XLocation = struct
  open Location
  let format = print_loc
  let merge t1 t2 = { t1 with loc_end = t2.loc_end }
  let ghost t = { t with loc_ghost = true }
end

module Open = struct
  open Ppxlib
  open Ppxlib.Ast

  let ($.) = XLongident.($.)

  let ghost = XLocation.ghost

  let raise_errorf = Location.raise_errorf

  let handle_error f =
    try f () with
    | e ->
        Format.eprintf "%a@."  Location.report_exception e;
        exit 2

  let def_loc = function
    | None -> !Ast_helper.default_loc
    | Some loc -> loc

  let at ?loc txt =
    let loc = match loc with
      | None -> !Ast_helper.default_loc
      | Some loc -> loc
    in
    { txt; loc }

  let (!@) x = at x

  let lid ?loc s = at ?loc & Longident.parse s

  let with_loc = Ast_helper.with_default_loc
  let with_gloc l = Ast_helper.with_default_loc (ghost l)

  let ocaml_warning ?loc s =
    (* [@@ocaml.warning "-39"] *)
    { attr_name = at ?loc "ocaml.warning";
      attr_payload= PStr [Str.eval ?loc (Exp.constant & Const.string s)];
      attr_loc= def_loc loc
    }

  let is_gadt type_decl = match type_decl.ptype_kind with
    | Ptype_variant constrs -> List.exists (fun c -> c.pcd_res <> None) constrs
    | _ -> false

  let (^.^) x y = x ^ "." ^ y
end

open Open

module Name = struct
  let make_unique =
    let cntr = ref 0 in
    fun n ->
      let x = !cntr in
      incr cntr;
      n ^ "_" ^ string_of_int x
end

module XTyp = struct
  open Typ
  let new_var =
    let cntr = ref 0 in
    fun prefixo ->
      incr cntr;
      let prefix = match prefixo with None -> "tvar" | Some n -> n in
      var & prefix ^ "_" ^ string_of_int !cntr
  let ref_ ?loc ?attrs ty =
    constr ?loc ?attrs (at ?loc & Longident.Lident "ref") [ty]
  let option ?loc ?attrs ty =
    constr ?loc ?attrs (at ?loc & Longident.(Ldot (Lident "*predef*", "option"))) [ty]
end

module XExp = struct
  open Exp
  let var ?loc ?attrs s = ident ?loc ?attrs & at ?loc & Longident.Lident s
  let lident ?loc ?attrs lid = ident ?loc ?attrs & at ?loc lid
  let id ?loc ?attrs s = ident ?loc ?attrs & at ?loc & XLongident.parse s

  let unit ?loc () = construct ?loc (at & Longident.Lident "()") None
  let string ?loc ?attrs s = constant ?loc ?attrs & Const.string s
  let int ?loc ?attrs i = constant ?loc ?attrs & Pconst_integer (string_of_int i, None)
  let bool ?loc ?attrs b = construct ?loc ?attrs (lid ?loc (if b then "true" else "false")) None
  let option ?loc ?attrs = function
    | None -> construct ?loc ?attrs (lid ?loc "None") None
    | Some e -> construct ?loc ?attrs (lid ?loc "Some") (Some e)

  let parse s =
    try
      Ppxlib.Parse.expression (Lexing.from_string s)
    with
    | _e -> failwith (Printf.sprintf "parse fail: %s" s)

  let object' ?loc ?attrs flds = object_ ?loc ?attrs (Cstr.mk (Pat.any ()) flds)
  let seqs = function
    | [] -> assert false
    | x::xs -> List.fold_right (fun x st -> sequence x st) xs x
  let ignore_ e = apply (id "Pervasives.ignore") [Nolabel, e]
  let assert_false () = assert_ & bool false

  let open_lid ?loc ?attrs ?(override=false) lid =
    open_ ?loc ?attrs
      { popen_expr= Mod.ident ?loc lid;
        popen_override = if override then Override else Fresh;
        popen_loc= def_loc loc;
        popen_attributes= [] }

  let list ?loc ?(attrs=[]) xs =
    let null = construct ?loc (lid ?loc "[]") None in
    let cons x xs = construct ?loc (lid ?loc "::") (Some (tuple ?loc [x;xs])) in
    { (List.fold_right cons xs null) with pexp_attributes = attrs }

  let with_desc e desc = { e with pexp_desc = desc }

  let is_simple_ext s e = match e.pexp_desc with
    | Pexp_extension ({ txt }, PStr []) -> txt = s
    | _ -> false

  let apply' ?loc ?attrs a b =
    match b with
    | [] -> a
    | _ ->
        let b = List.map (fun e -> Nolabel, e) b in
        mk ?loc ?attrs (Pexp_apply (a, b))

  let tuple' ?loc = function
    | [] -> unit ?loc ()
    | [x] -> x
    | xs -> tuple ?loc xs
end

module XPat = struct
  open Pat
  let var' ?loc ?attrs s = var ?loc ?attrs (at ?loc s)
  let unit ?loc () = construct ?loc (at & Longident.Lident "()") None
  let string ?loc s = constant ?loc (Pconst_string (s,def_loc loc,None))
  let rec list = function
    | [] -> construct (lid "([])") None (* XXX Stdlib.([])? *)
    | x::xs ->
        construct (lid "(::)") (Some (tuple [x; list xs])) (* XXX Stdlib.(::) *)

  exception Not_supported of expression

  let of_expr e =
    let rec f e =
      let loc = e.pexp_loc in
      let attrs = e.pexp_attributes in
      match e.pexp_desc with
      | Pexp_ident {txt=Lident s; loc=loc'} ->
          Pat.var ~loc ~attrs {txt=s; loc=loc'}
      | Pexp_constant c -> Pat.constant ~loc ~attrs c
      | Pexp_tuple es -> Pat.tuple ~loc ~attrs & List.map f es
      | Pexp_construct (lid, eopt) ->
          Pat.construct ~loc ~attrs lid & Option.map f eopt
      | Pexp_variant (l, eopt) ->
          Pat.variant ~loc ~attrs l & Option.map f eopt
      | Pexp_record (fields , None) ->
          Pat.record ~loc ~attrs (List.map (fun (lid, e) -> lid, f e) fields) Closed
      | Pexp_array es -> Pat.array ~loc ~attrs & List.map f es
      | Pexp_constraint (e, ty) -> Pat.constraint_ ~loc ~attrs (f e) ty
      | Pexp_lazy e -> Pat.lazy_ ~loc ~attrs & f e
      | Pexp_extension ({txt="p"}, PPat (p, None)) -> p
      | _ -> raise (Not_supported e)
    in
    try
      `Ok (f e)
    with
    | Not_supported e -> `Error e

  let tuple' ?loc = function
    | [] -> unit ?loc ()
    | [x] -> x
    | xs -> tuple ?loc xs
end

module ExpPat = struct
  let var ?loc ?attrs s = (XExp.var ?loc ?attrs s, XPat.var' ?loc ?attrs s)
end

module XCf = struct
  open Cf
  let method_concrete ?loc ?attrs name ?(priv=false) ?(override=false) e =
    Cf.method_ ?loc ?attrs name (if priv then Private else Public)
      (Cfk_concrete ((if override then Override else Fresh), e))
  let method_virtual ?loc ?attrs name ?(priv=false) cty =
    Cf.method_ ?loc ?attrs name (if priv then Private else Public)
      (Cfk_virtual cty)
  let inherit_ ?loc ?attrs ?(override=false) =
    inherit_ ?loc ?attrs (if override then Override else Fresh)
  let concrete ?(override=false) =
    concrete (if override then Override else Fresh)
  (** [override]'s default is [false] *)
end

module XCstr = struct
  let mk' ?(self= Pat.any ()) fields = Cstr.mk self fields
end

module XMod = struct
  open Mod
  let ident' ?loc lid = ident ?loc (at ?loc lid)
end

module XAttr = struct
  (** Make [@ocaml.<k> <e>] *)
  let ocaml ?loc k e =
    { attr_name= at ?loc ("ocaml." ^ k);
      attr_payload= PStr [Str.eval e];
      attr_loc= def_loc loc }
end

module XOpn = struct
  open Opn
  let mk ?loc ?attrs ?(override=false) =
    mk ?loc ?attrs ~override:(if override then Override else Fresh)
end

module XSig = struct
  open Sig
  let type_ ?loc ?(rec_flag=Recursive) tds = type_ ?loc rec_flag tds
end

module XStr = struct
  open Str
  let type_ ?loc ?(rec_flag=Recursive) tds = type_ ?loc rec_flag tds
end