Imported Upstream version 3.3

6 files changed, 1035 insertions, 0 deletions

diff --git a/src/ppx_deriving.cppo.ml b/src/ppx_deriving.cppo.ml
new file mode 100644
index 0000000..d12c8b4
--- /dev/null
+++ b/src/ppx_deriving.cppo.ml
@@ -0,0 +1,526 @@
+#if OCAML_VERSION < (4, 03, 0)
+#define Pconst_char Const_char
+#define Pconst_string Const_string
+#define Pstr_type(rec_flag, type_decls) Pstr_type(type_decls)
+#define Psig_type(rec_flag, type_decls) Psig_type(type_decls)
+#endif
+
+open Longident
+open Location
+open Asttypes
+open Parsetree
+open Ast_helper
+open Ast_convenience
+
+type deriver = {
+  name : string ;
+  core_type : (core_type -> expression) option;
+  type_decl_str : options:(string * expression) list -> path:string list ->
+                   type_declaration list -> structure;
+  type_ext_str : options:(string * expression) list -> path:string list ->
+                  type_extension -> structure;
+  type_decl_sig : options:(string * expression) list -> path:string list ->
+                   type_declaration list -> signature;
+  type_ext_sig : options:(string * expression) list -> path:string list ->
+                  type_extension -> signature;
+}
+
+let registry : (string, deriver) Hashtbl.t
+             = Hashtbl.create 16
+
+let register d = Hashtbl.add registry d.name d
+
+let lookup name =
+  try  Some (Hashtbl.find registry name)
+  with Not_found -> None
+
+let raise_errorf ?sub ?if_highlight ?loc message =
+  message |> Printf.kprintf (fun str ->
+    let err = Location.error ?sub ?if_highlight ?loc str in
+    raise (Location.Error err))
+
+let create =
+  let def_ext_str name ~options ~path typ_ext =
+    raise_errorf "Extensible types in structures not supported by deriver %s" name
+  in
+  let def_ext_sig name ~options ~path typ_ext =
+    raise_errorf "Extensible types in signatures not supported by deriver %s" name
+  in
+  let def_decl_str name ~options ~path typ_decl =
+    raise_errorf "Type declarations in structures not supported by deriver %s" name
+  in
+  let def_decl_sig name ~options ~path typ_decl =
+    raise_errorf "Type declaratons in signatures not supported by deriver %s" name
+  in
+  fun name ?core_type
+    ?(type_ext_str=def_ext_str name)
+    ?(type_ext_sig=def_ext_sig name)
+    ?(type_decl_str=def_decl_str name)
+    ?(type_decl_sig=def_decl_sig name)
+    () ->
+      { name ; core_type ;
+        type_decl_str ; type_ext_str ;
+        type_decl_sig ; type_ext_sig ;
+      }
+
+let string_of_core_type typ =
+  Format.asprintf "%a" Pprintast.core_type { typ with ptyp_attributes = [] }
+
+module Arg = struct
+  let expr expr =
+    `Ok expr
+
+  let int expr =
+    match expr with
+#if OCAML_VERSION < (4, 03, 0)
+    | { pexp_desc = Pexp_constant (Const_int n) } -> `Ok n
+#else
+    | { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> `Ok (int_of_string sn)
+#endif
+    | _ -> `Error "integer"
+
+  let bool expr =
+    match expr with
+    | [%expr true] -> `Ok true
+    | [%expr false] -> `Ok false
+    | _ -> `Error "boolean"
+
+  let string expr =
+    match expr with
+    | { pexp_desc = Pexp_constant (Pconst_string (n, None)) } -> `Ok n
+    | _ -> `Error "string"
+
+  let char = function
+    | { pexp_desc = Pexp_constant (Pconst_char c) } -> `Ok c
+    | _ -> `Error "char"
+
+  let enum values expr =
+    match expr with
+    | { pexp_desc = Pexp_variant (name, None) }
+      when List.mem name values -> `Ok name
+    | _ -> `Error (Printf.sprintf "one of: %s"
+                    (String.concat ", " (List.map (fun s -> "`"^s) values)))
+
+  let list expr =
+    let rec loop acc = function
+      | [%expr []] -> `Ok (List.rev acc)
+      | [%expr [%e? x]::[%e? xs]] ->
+        begin match expr x with
+        | `Ok v -> loop (v::acc) xs
+        | `Error e -> `Error ("list:" ^ e)
+        end
+      | _ -> `Error "list"
+    in loop []
+
+  let get_attr ~deriver conv attr =
+    match attr with
+    | None -> None
+    | Some ({ txt = name }, PStr [{ pstr_desc = Pstr_eval (expr, []) }]) ->
+      begin match conv expr with
+      | `Ok v -> Some v
+      | `Error desc ->
+        raise_errorf ~loc:expr.pexp_loc "%s: invalid [@%s]: %s expected" deriver name desc
+      end
+    | Some ({ txt = name; loc }, _) ->
+      raise_errorf ~loc "%s: invalid [@%s]: value expected" deriver name
+
+  let get_flag ~deriver attr =
+    match attr with
+    | None -> false
+    | Some ({ txt = name }, PStr []) -> true
+    | Some ({ txt = name; loc }, _) ->
+      raise_errorf ~loc "%s: invalid [@%s]: empty structure expected" deriver name
+
+  let get_expr ~deriver conv expr =
+    match conv expr with
+    | `Error desc -> raise_errorf ~loc:expr.pexp_loc "%s: %s expected" deriver desc
+    | `Ok v -> v
+end
+
+type quoter = {
+  mutable next_id : int;
+  mutable bindings : value_binding list;
+}
+
+let create_quoter () = { next_id = 0; bindings = [] }
+
+let quote ~quoter expr =
+  let name = "__" ^ string_of_int quoter.next_id in
+  quoter.bindings <- (Vb.mk (pvar name) [%expr fun () -> [%e expr]]) :: quoter.bindings;
+  quoter.next_id <- quoter.next_id + 1;
+  [%expr [%e evar name] ()]
+
+let sanitize ?(quoter=create_quoter ()) expr =
+  let body = [%expr (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] in
+  match quoter.bindings with
+  | [] -> body
+  | bindings -> Exp.let_ Nonrecursive bindings body
+
+let with_quoter fn a =
+  let quoter = create_quoter () in
+  sanitize ~quoter (fn quoter a)
+
+let expand_path ~path ident =
+  String.concat "." (path @ [ident])
+
+let path_of_type_decl ~path type_decl =
+  match type_decl.ptype_manifest with
+  | Some { ptyp_desc = Ptyp_constr ({ txt = lid }, _) } ->
+    begin match lid with
+    | Lident _ -> []
+    | Ldot (lid, _) -> Longident.flatten lid
+    | Lapply _ -> assert false
+    end
+  | _ -> path
+
+let mangle ?(fixpoint="t") affix name =
+  match name = fixpoint, affix with
+  | true,  (`Prefix x | `Suffix x) -> x
+  | true, `PrefixSuffix (p, s) -> p ^ "_" ^ s
+  | false, `PrefixSuffix (p, s) -> p ^ "_" ^ name ^ "_" ^ s
+  | false, `Prefix x -> x ^ "_" ^ name
+  | false, `Suffix x -> name ^ "_" ^ x
+
+let mangle_type_decl ?fixpoint affix { ptype_name = { txt = name } } =
+  mangle ?fixpoint affix name
+
+let mangle_lid ?fixpoint affix lid =
+  match lid with
+  | Lident s    -> Lident (mangle ?fixpoint affix s)
+  | Ldot (p, s) -> Ldot (p, mangle ?fixpoint affix s)
+  | Lapply _    -> assert false
+
+let attr ~deriver name attrs =
+  let starts str prefix =
+    String.length str >= String.length prefix &&
+      String.sub str 0 (String.length prefix) = prefix
+  in
+  let try_prefix prefix f =
+    if List.exists (fun ({ txt }, _) -> starts txt prefix) attrs
+    then prefix ^ name
+    else f ()
+  in
+  let name =
+    try_prefix ("deriving."^deriver^".") (fun () ->
+      try_prefix (deriver^".") (fun () ->
+        name))
+  in
+  try Some (List.find (fun ({ txt }, _) -> txt = name) attrs)
+  with Not_found -> None
+
+let attr_warning expr =
+  let loc = !default_loc in
+  let structure = {pstr_desc = Pstr_eval (expr, []); pstr_loc = loc} in
+  {txt = "ocaml.warning"; loc}, PStr [structure]
+
+let fold_left_type_params fn accum params =
+  List.fold_left (fun accum (param, _) ->
+      match param with
+      | { ptyp_desc = Ptyp_any } -> accum
+      | { ptyp_desc = Ptyp_var name } ->
+        fn accum name
+      | _ -> assert false)
+    accum params
+
+let fold_left_type_decl fn accum { ptype_params } =
+  fold_left_type_params fn accum ptype_params
+
+let fold_left_type_ext fn accum { ptyext_params } =
+  fold_left_type_params fn accum ptyext_params
+
+let fold_right_type_params fn params accum =
+  List.fold_right (fun (param, _) accum ->
+      match param with
+      | { ptyp_desc = Ptyp_any } -> accum
+      | { ptyp_desc = Ptyp_var name } ->
+        fn name accum
+      | _ -> assert false)
+    params accum
+
+let fold_right_type_decl fn { ptype_params } accum =
+  fold_right_type_params fn ptype_params accum
+
+let fold_right_type_ext fn { ptyext_params } accum =
+  fold_right_type_params fn ptyext_params accum
+
+let free_vars_in_core_type typ =
+  let rec free_in typ =
+    match typ with
+    | { ptyp_desc = Ptyp_any } -> []
+    | { ptyp_desc = Ptyp_var name } -> [name]
+    | { ptyp_desc = Ptyp_arrow (_, x, y) } -> free_in x @ free_in y
+    | { ptyp_desc = (Ptyp_tuple xs | Ptyp_constr (_, xs)) } ->
+      List.map free_in xs |> List.concat
+    | { ptyp_desc = Ptyp_alias (x, name) } -> [name] @ free_in x
+    | { ptyp_desc = Ptyp_poly (bound, x) } ->
+      List.filter (fun y -> not (List.mem y bound)) (free_in x)
+    | { ptyp_desc = Ptyp_variant (rows, _, _) } ->
+      List.map (
+          function Rtag (_,_,_,ts) -> List.map free_in ts
+                 | Rinherit t -> [free_in t]
+        ) rows |> List.concat |> List.concat
+    | _ -> assert false
+  in
+  let rec uniq acc lst =
+    match lst with
+    | a :: b :: lst when a = b -> uniq acc (b :: lst)
+    | x :: lst -> uniq (x :: acc) lst
+    | [] -> acc
+  in
+  List.rev (uniq [] (free_in typ))
+
+let var_name_of_int i =
+  let letter = "abcdefghijklmnopqrstuvwxyz" in
+  let rec loop i =
+    if i < 26 then [letter.[i]] else letter.[i mod 26] :: loop (i / 26)
+  in
+  String.concat "" (List.map (String.make 1) (loop i))
+
+let fresh_var bound =
+  let rec loop i =
+    let var_name = var_name_of_int i in
+    if List.mem var_name bound then loop (i + 1) else var_name
+  in
+  loop 0
+
+let poly_fun_of_type_decl type_decl expr =
+  fold_right_type_decl (fun name expr ->
+    Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_decl expr
+
+let poly_fun_of_type_ext type_ext expr =
+  fold_right_type_ext (fun name expr ->
+    Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_ext expr
+
+let poly_apply_of_type_decl type_decl expr =
+  fold_left_type_decl (fun expr name ->
+    Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_decl
+
+let poly_apply_of_type_ext type_ext expr =
+  fold_left_type_ext (fun expr name ->
+    Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_ext
+
+let poly_arrow_of_type_decl fn type_decl typ =
+  fold_right_type_decl (fun name typ ->
+    Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_decl typ
+
+let poly_arrow_of_type_ext fn type_ext typ =
+  fold_right_type_ext (fun name typ ->
+    Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_ext typ
+
+let core_type_of_type_decl { ptype_name = { txt = name }; ptype_params } =
+  Typ.constr (mknoloc (Lident name)) (List.map fst ptype_params)
+
+let core_type_of_type_ext { ptyext_path ; ptyext_params } =
+  Typ.constr ptyext_path (List.map fst ptyext_params)
+
+let instantiate bound type_decl =
+  let vars, bound =
+    List.fold_right
+      (fun _ (vars, bound) ->
+        let v = fresh_var bound in (v :: vars, v :: bound))
+      (free_vars_in_core_type (core_type_of_type_decl type_decl))
+      ([], bound)
+  in
+  let vars = List.rev vars in
+  let core_type = core_type_of_type_decl
+    { type_decl with
+        ptype_params = List.map2 (fun v (_, variance) -> Typ.var v, variance)
+                                 vars type_decl.ptype_params }
+  in
+  core_type, vars, bound
+
+let fold_exprs ?unit fn exprs =
+  match exprs with
+  | [a] -> a
+  | hd::tl -> List.fold_left fn hd tl
+  | [] ->
+    match unit with
+    | Some x -> x
+    | None -> raise (Invalid_argument "Ppx_deriving.fold_exprs")
+
+let seq_reduce ?sep a b =
+  match sep with
+  | Some x -> [%expr [%e a]; [%e x]; [%e b]]
+  | None -> [%expr [%e a]; [%e b]]
+
+let binop_reduce x a b =
+  [%expr [%e x] [%e a] [%e b]]
+
+let strong_type_of_type ty =
+  let free_vars = free_vars_in_core_type ty in
+  Typ.force_poly @@ Typ.poly free_vars ty
+
+let derive path pstr_loc item attributes fn arg =
+  let deriving = find_attr "deriving" attributes in
+  let deriver_exprs, loc =
+    match deriving with
+    | Some (PStr [{ pstr_desc = Pstr_eval (
+                    { pexp_desc = Pexp_tuple exprs }, []); pstr_loc }]) ->
+      exprs, pstr_loc
+    | Some (PStr [{ pstr_desc = Pstr_eval (
+                    { pexp_desc = (Pexp_ident _ | Pexp_apply _) } as expr, []); pstr_loc }]) ->
+      [expr], pstr_loc
+    | _ -> raise_errorf ~loc:pstr_loc "Unrecognized [@@deriving] annotation syntax"
+  in
+  List.fold_left (fun items deriver_expr ->
+      let name, options =
+        match deriver_expr with
+        | { pexp_desc = Pexp_ident name } ->
+          name, []
+        | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, [label,
+            { pexp_desc = Pexp_record (options, None) }]) }
+              when label = Label.nolabel ->
+          name, options |> List.map (fun ({ txt }, expr) ->
+            String.concat "." (Longident.flatten txt), expr)
+        | { pexp_loc } ->
+          raise_errorf ~loc:pexp_loc "Unrecognized [@@deriving] option syntax"
+      in
+      let name, loc = String.concat "_" (Longident.flatten name.txt), name.loc in
+      let is_optional, options =
+        match List.assoc "optional" options with
+        | exception Not_found -> false, options
+        | expr ->
+          Arg.(get_expr ~deriver:name bool) expr,
+          List.remove_assoc "optional" options
+      in
+      match lookup name with
+      | Some deriver ->
+        items @ ((fn deriver) ~options ~path:(!path) arg)
+      | None ->
+        if is_optional then items
+        else raise_errorf ~loc "Cannot locate deriver %s" name)
+    [item] deriver_exprs
+
+let derive_type_decl path typ_decls pstr_loc item fn =
+  let attributes = List.concat (List.map (fun { ptype_attributes = attrs } -> attrs) typ_decls) in
+  derive path pstr_loc item attributes fn typ_decls
+
+let derive_type_ext path typ_ext pstr_loc item fn =
+  let attributes = typ_ext.ptyext_attributes in
+  derive path pstr_loc item attributes fn typ_ext
+
+let module_from_input_name () =
+  match !Location.input_name with
+  | "//toplevel//" -> []
+  | filename -> [String.capitalize (Filename.(basename (chop_suffix filename ".ml")))]
+
+let mapper =
+  let module_nesting = ref [] in
+  let with_module name f =
+    let old_nesting = !module_nesting in
+    module_nesting := !module_nesting @ [name];
+    let result = f () in
+    module_nesting := old_nesting;
+    result
+  in
+  let expression mapper expr =
+    match expr with
+    | { pexp_desc = Pexp_extension ({ txt = name; loc }, payload) }
+        when String.(length name >= 7 && sub name 0 7 = "derive.") ->
+      let name = String.sub name 7 ((String.length name) - 7) in
+      let deriver =
+        match lookup name with
+        | Some { core_type = Some deriver } -> deriver
+        | Some _ -> raise_errorf ~loc "Deriver %s does not support inline notation" name
+        | None -> raise_errorf ~loc "Cannot locate deriver %s" name
+      in
+      begin match payload with
+      | PTyp typ -> deriver typ
+      | _ -> raise_errorf ~loc "Unrecognized [%%derive.*] syntax"
+      end
+    | { pexp_desc = Pexp_extension ({ txt = name; loc }, PTyp typ) } ->
+      begin match lookup name with
+      | Some { core_type = Some deriver } ->
+        Ast_helper.with_default_loc typ.ptyp_loc (fun () -> deriver typ)
+      | _ -> Ast_mapper.(default_mapper.expr) mapper expr
+      end
+    | _ -> Ast_mapper.(default_mapper.expr) mapper expr
+  in
+  let structure mapper items =
+    match items with
+    | { pstr_desc = Pstr_type(_, typ_decls); pstr_loc } as item :: rest when
+        List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls ->
+      let derived =
+        Ast_helper.with_default_loc pstr_loc (fun () ->
+          derive_type_decl module_nesting typ_decls pstr_loc item
+            (fun deriver -> deriver.type_decl_str))
+      in derived @ mapper.Ast_mapper.structure mapper rest
+    | { pstr_desc = Pstr_typext typ_ext; pstr_loc } as item :: rest when
+          has_attr "deriving" typ_ext.ptyext_attributes ->
+      let derived =
+        Ast_helper.with_default_loc pstr_loc (fun () ->
+          derive_type_ext module_nesting typ_ext pstr_loc item
+            (fun deriver -> deriver.type_ext_str))
+      in derived @ mapper.Ast_mapper.structure mapper rest
+    | { pstr_desc = Pstr_module ({ pmb_name = { txt = name } } as mb) } as item :: rest ->
+      let derived =
+        { item with pstr_desc = Pstr_module (
+            with_module name
+              (fun () -> mapper.Ast_mapper.module_binding mapper mb)) }
+      in derived :: mapper.Ast_mapper.structure mapper rest
+    | { pstr_desc = Pstr_recmodule mbs } as item :: rest ->
+      let derived =
+        { item with pstr_desc = Pstr_recmodule (
+            mbs |> List.map (fun ({ pmb_name = { txt = name } } as mb) ->
+              with_module name
+                (fun () -> mapper.Ast_mapper.module_binding mapper mb))) }
+      in derived :: mapper.Ast_mapper.structure mapper rest
+    | { pstr_loc } as item :: rest ->
+      let derived = mapper.Ast_mapper.structure_item mapper item
+      in derived :: mapper.Ast_mapper.structure mapper rest
+    | [] -> []
+  in
+  let signature mapper items =
+    match items with
+    | { psig_desc = Psig_type(_, typ_decls); psig_loc } as item :: rest when
+        List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls ->
+      let derived =
+        Ast_helper.with_default_loc psig_loc (fun () ->
+          derive_type_decl module_nesting typ_decls psig_loc item
+            (fun deriver -> deriver.type_decl_sig))
+      in derived @ mapper.Ast_mapper.signature mapper rest
+    | { psig_desc = Psig_typext typ_ext; psig_loc } as item :: rest when
+        has_attr "deriving" typ_ext.ptyext_attributes ->
+      let derived =
+        Ast_helper.with_default_loc psig_loc (fun () ->
+          derive_type_ext module_nesting typ_ext psig_loc item
+            (fun deriver -> deriver.type_ext_sig))
+      in derived @ mapper.Ast_mapper.signature mapper rest
+    | { psig_desc = Psig_module ({ pmd_name = { txt = name } } as md) } as item :: rest ->
+      let derived =
+        { item with psig_desc = Psig_module (
+            with_module name
+              (fun () -> mapper.Ast_mapper.module_declaration mapper md)) }
+      in derived :: mapper.Ast_mapper.signature mapper rest
+    | { psig_desc = Psig_recmodule mds } as item :: rest ->
+      let derived =
+        { item with psig_desc = Psig_recmodule (
+            mds |> List.map (fun ({ pmd_name = { txt = name } } as md) ->
+              with_module name
+                (fun () -> mapper.Ast_mapper.module_declaration mapper md))) }
+      in derived :: mapper.Ast_mapper.signature mapper rest
+    | { psig_loc } as item :: rest ->
+      let derived =
+        mapper.Ast_mapper.signature_item mapper item
+      in derived :: mapper.Ast_mapper.signature mapper rest
+    | [] -> []
+  in
+  Ast_mapper.{default_mapper with
+    expr = expression;
+    structure = (fun mapper items ->
+      module_nesting := module_from_input_name ();
+      structure { mapper with structure; signature } items);
+    signature = (fun mapper items ->
+      module_nesting := module_from_input_name ();
+      signature { mapper with structure; signature } items)
+  }
+
+let hash_variant s =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
diff --git a/src/ppx_deriving.mli b/src/ppx_deriving.mli
new file mode 100644
index 0000000..8714e66
--- /dev/null
+++ b/src/ppx_deriving.mli
@@ -0,0 +1,295 @@
+(** Public API of [ppx_deriving] executable. *)
+
+open Parsetree
+
+(** {2 Registration} *)
+
+(** A type of deriving plugins.
+
+    A structure or signature deriving function accepts a list of
+    [~options], a [~path] of modules for the type declaration currently
+    being processed (with [[]] for toplevel phrases), and a type declaration
+    item ([type t = .. and t' = ..]), and returns a list of items to be
+    appended after the type declaration item in structure and signature.
+    It is invoked by [[\@\@deriving]] annotations.
+
+    A type deriving function accepts a type and returns a corresponding
+    derived expression. It is invoked by [[%derive.foo:]] and [[%foo:]]
+    annotations. If this function is missing, the corresponding [[%foo:]]
+    annotation is ignored.
+
+    The structure and signature deriving functions are invoked in
+    the order in which they appear in the source code. *)
+type deriver = {
+  name : string ;
+  core_type : (core_type -> expression) option;
+  type_decl_str : options:(string * expression) list -> path:string list ->
+                   type_declaration list -> structure;
+  type_ext_str : options:(string * expression) list -> path:string list ->
+                   type_extension -> structure;
+  type_decl_sig : options:(string * expression) list -> path:string list ->
+                   type_declaration list -> signature;
+  type_ext_sig : options:(string * expression) list -> path:string list ->
+                  type_extension -> signature;
+}
+
+(** [register deriver] registers [deriver] according to its [name] field. *)
+val register : deriver -> unit
+
+(** Creating {!deriver} structure. *)
+val create :
+  string ->
+  ?core_type: (core_type -> expression) ->
+  ?type_ext_str: (options:(string * expression) list -> path:string list ->
+                   type_extension -> structure) ->
+  ?type_ext_sig: (options:(string * expression) list -> path:string list ->
+                   type_extension -> signature) ->
+  ?type_decl_str: (options:(string * expression) list -> path:string list ->
+                    type_declaration list -> structure) ->
+  ?type_decl_sig: (options:(string * expression) list -> path:string list ->
+                    type_declaration list -> signature) ->
+  unit -> deriver
+
+(** [lookup name] looks up a deriver called [name]. *)
+val lookup : string -> deriver option
+
+(** {2 Error handling} *)
+
+(** [raise_error] is a shorthand for raising [Location.Error] with the result
+    of [Location.errorf]. *)
+val raise_errorf : ?sub:Location.error list -> ?if_highlight:string ->
+                   ?loc:Location.t -> ('a, unit, string, 'b) format4 -> 'a
+
+(** [string_of_core_type typ] unparses [typ], omitting any attributes. *)
+val string_of_core_type : Parsetree.core_type -> string
+
+(** {2 Option parsing} *)
+
+(** {!Arg} contains convenience functions that extract constants from
+    AST fragments, to be used when parsing options or [[\@attributes]]
+    attached to types, fields or constructors.
+
+    The [~name] argument is used in error messages and should receive
+    the name of the deriving plugin, e.g. ["show"]. *)
+module Arg : sig
+  (** [expr] returns the input expression as-is. *)
+  val expr : expression -> [> `Ok of expression ]
+
+  (** [bool expr] extracts a boolean constant from [expr], or returns
+      [`Error "boolean"] if [expr] does not contain a boolean literal. *)
+  val bool : expression -> [ `Ok of bool | `Error of string ]
+
+  (** [int expr] extracts an integer constant from [expr], or returns
+      [`Error "integer"] if [expr] does not contain an integer literal. *)
+  val int : expression -> [ `Ok of int | `Error of string ]
+
+  (** [string expr] extracts a string constant from [expr], or returns
+      [`Error "string"] if [expr] does not contain a string literal. *)
+  val string : expression -> [ `Ok of string | `Error of string ]
+
+  (** [char expr] extracts a char constant from [expr], or returns
+      [`Error "char"] if [expr] does not contain a char literal. *)
+  val char : expression -> [ `Ok of char | `Error of string ]
+
+  (** [enum values expr] extracts a polymorphic variant constant from [expr],
+      or returns [`Error "one of: `a, `b, ..."] if [expr] does not contain
+      a polymorphic variant constructor included in [values]. *)
+  val enum : string list -> expression -> [ `Ok of string | `Error of string ]
+
+  (** [list f expr] extracts a list constant from [expr] and maps every element
+      through [f], or returns [`Error "list:..."] where [...] is the error returned
+      by [f], or returns [`Error "list"] if [expr] does not contain a list. *)
+  val list : (expression -> [`Ok of 'a | `Error of string]) ->
+             expression -> [`Ok of 'a list | `Error of string]
+
+  (** [get_attr ~deriver conv attr] extracts the expression from [attr] and converts
+      it with [conv], raising [Location.Error] if [attr] is not a structure with
+      a single expression or [conv] fails; or returns [None] if [attr] is [None].
+      The name of the deriving plugin should be passed as [deriver]; it is used
+      in error messages.
+
+      Example usage:
+      {[
+let deriver = "index"
+(* ... *)
+  let kind =
+    match Ppx_deriving.attr ~deriver "kind" pcd_attributes |>
+          Ppx_deriving.Arg.(get_attr ~deriver (enum ["flat"; "nested"])) with
+    | Some "flat" -> `flat | Some "nested" -> `nested | None -> `default
+  in ..
+      ]} *)
+  val get_attr : deriver:string -> (expression -> [ `Ok of 'a | `Error of string ]) ->
+                 attribute option -> 'a option
+
+  (** [get_flag ~deriver attr] returns [true] if [attr] is an empty attribute
+      or [false] if it is absent, raising [Location.Error] if [attr] is not
+      a structure.
+      The name of the deriving plugin should be passed as [deriver]; it is used
+      in error messages. *)
+  val get_flag : deriver:string -> attribute option -> bool
+
+  (** [get_expr ~deriver conv exp] converts expression [exp] with [conv], raising
+      [Location.Error] if [conv] fails.
+      The name of the deriving plugin should be passed as [deriver]; it is used
+      in error messages. *)
+  val get_expr : deriver:string -> (expression -> [ `Ok of 'a | `Error of string ]) ->
+                 expression -> 'a
+end
+
+(** {2 Hygiene} *)
+
+(** A [quoter] remembers a set of expressions. *)
+type quoter
+
+(** [quoter ()] creates an empty quoter. *)
+val create_quoter : unit -> quoter
+
+(** [quote quoter expr] records a pure expression [expr] within [quoter] and
+    returns an expression which has the same value as [expr] in the context
+    that [sanitize] provides. *)
+val quote : quoter:quoter -> expression -> expression
+
+(** [sanitize quoter expr] wraps [expr] in a way that ensures that the contents of
+    {!Ppx_deriving_runtime} and {!Pervasives}, as well as the identifiers in
+    expressions returned by [quote] are in scope, and returns the wrapped expression. *)
+val sanitize : ?quoter:quoter -> expression -> expression
+
+(** [with_quoter fn] ≡
+    [fun fn a -> let quoter = create_quoter () in sanitize ~quoter (fn quoter a)] *)
+val with_quoter : (quoter -> 'a -> expression) -> 'a -> expression
+
+(** {2 AST manipulation} *)
+
+(** [expand_path name] returns [name] with the [path] module path prepended,
+    e.g. [expand_path ["Foo";"M"] "t"] = ["Foo.M.t"] and [expand_path [] "t"] = ["t"] *)
+val expand_path : path:string list -> string -> string
+
+(** [path_of_type_decl ~path type_] returns [path] if [type_] does not have a manifest
+    or the manifest is not a constructor, and the module path of manifest otherwise.
+
+    [path_of_type_decl] is useful when determining the canonical path location
+    of fields and constructors; e.g. for [type bar = M.foo = A | B], it will return
+    [["M"]]. *)
+val path_of_type_decl : path:string list -> type_declaration -> string list
+
+(** [mangle_type_decl ~fixpoint affix type_] derives a function name from [type_] name
+    by doing nothing if [type_] is named [fixpoint] (["t"] by default), or
+    appending and/or prepending [affix] via an underscore. *)
+val mangle_type_decl :
+   ?fixpoint:string ->
+   [ `Prefix of string | `Suffix of string | `PrefixSuffix of string * string ] ->
+   type_declaration -> string
+
+(** [mangle_lid ~fixpoint affix lid] does the same as {!mangle_type_decl}, but for
+    the last component of [lid]. *)
+val mangle_lid : ?fixpoint:string ->
+   [ `Prefix of string | `Suffix of string | `PrefixSuffix of string * string] ->
+   Longident.t -> Longident.t
+
+(** [attr ~deriver name attrs] searches for an attribute [\[\@deriving.deriver.attr\]]
+    in [attrs] if any attribute with name starting with [\@deriving.deriver] exists,
+    or [\[\@deriver.attr\]] if any attribute with name starting with [\@deriver] exists,
+    or [\[\@attr\]] otherwise. *)
+val attr : deriver:string -> string -> attributes -> attribute option
+
+(** [attr_warning expr] builds the attribute [\@ocaml.warning expr] *)
+val attr_warning: expression -> attribute
+
+(** [free_vars_in_core_type typ] returns unique free variables in [typ] in
+    lexical order. *)
+val free_vars_in_core_type : core_type -> string list
+
+(** [fresh_var bound] returns a fresh variable name not present in [bound].
+    The name is selected in alphabetical succession. *)
+val fresh_var : string list -> string
+
+(** [fold_left_type_decl fn accum type_] performs a left fold over all type variable
+    (i.e. not wildcard) parameters in [type_]. *)
+val fold_left_type_decl : ('a -> string -> 'a) -> 'a -> type_declaration -> 'a
+
+(** [fold_right_type_decl fn accum type_] performs a right fold over all type variable
+    (i.e. not wildcard) parameters in [type_]. *)
+val fold_right_type_decl : (string -> 'a -> 'a) -> type_declaration -> 'a -> 'a
+
+(** [fold_left_type_ext fn accum type_] performs a left fold over all type variable (i.e. not
+    wildcard) parameters in [type_]. *)
+val fold_left_type_ext : ('a -> string -> 'a) -> 'a -> type_extension -> 'a
+
+(** [fold_right_type_ext fn accum type_] performs a right fold over all type variable (i.e. not
+    wildcard) parameters in [type_]. *)
+val fold_right_type_ext : (string -> 'a -> 'a) -> type_extension -> 'a -> 'a
+
+(** [poly_fun_of_type_decl type_ expr] wraps [expr] into [fun poly_N -> ...] for every
+    type parameter ['N] present in [type_]. For example, if [type_] refers to
+    [type ('a, 'b) map], [expr] will be wrapped into [fun poly_a poly_b -> [%e expr]].
+
+    [_] parameters are ignored.  *)
+val poly_fun_of_type_decl : type_declaration -> expression -> expression
+
+(** Same as {!poly_fun_of_type_decl} but for type extension. *)
+val poly_fun_of_type_ext : type_extension -> expression -> expression
+
+(** [poly_apply_of_type_decl type_ expr] wraps [expr] into [expr poly_N] for every
+    type parameter ['N] present in [type_]. For example, if [type_] refers to
+    [type ('a, 'b) map], [expr] will be wrapped into [[%e expr] poly_a poly_b].
+
+    [_] parameters are ignored. *)
+val poly_apply_of_type_decl : type_declaration -> expression -> expression
+
+(** Same as {!poly_apply_of_type_decl} but for type extension. *)
+val poly_apply_of_type_ext : type_extension -> expression -> expression
+
+(** [poly_arrow_of_type_decl fn type_ typ] wraps [typ] in an arrow with [fn [%type: 'N]]
+    as argument for every type parameter ['N] present in [type_]. For example, if
+    [type_] refers to [type ('a, 'b) map] and [fn] is [fun var -> [%type: [%t var] -> string]],
+    [typ] will be wrapped into [('a -> string) -> ('b -> string) -> [%t typ]].
+
+    [_] parameters are ignored. *)
+val poly_arrow_of_type_decl : (core_type -> core_type) ->
+                              type_declaration -> core_type -> core_type
+
+(** Same as {!poly_arrow_of_type_decl} but for type extension. *)
+val poly_arrow_of_type_ext : (core_type -> core_type) ->
+                              type_extension -> core_type -> core_type
+
+(** [core_type_of_type_decl type_] constructs type [('a, 'b, ...) t] for
+    type declaration [type ('a, 'b, ...) t = ...]. *)
+val core_type_of_type_decl : type_declaration -> core_type
+
+(** Same as {!core_type_of_type_decl} but for type extension. *)
+val core_type_of_type_ext : type_extension -> core_type
+
+(** [instantiate bound type_] returns [typ, vars, bound'] where [typ] is a type
+    instantiated from type declaration [type_], [vars] ≡ [free_vars_in_core_type typ]
+    and [bound'] ≡ [bound @ vars]. *)
+val instantiate : string list -> type_declaration ->
+                  core_type * string list * string list
+
+(** [fold_exprs ~unit fn exprs] folds [exprs] using head of [exprs] as initial
+    accumulator value, or [unit] if [exprs = []].
+
+    See also {!seq_reduce} and {!binop_reduce}. *)
+val fold_exprs : ?unit:expression -> (expression -> expression -> expression) ->
+                 expression list -> expression
+
+(** When [sep] is present:
+    [seq_reduce] ≡ [fun x a b -> [%expr [%e a]; [%e x]; [%e b]]].
+    When [sep] is missing:
+    [seq_reduce] ≡ [fun a b -> [%expr [%e a]; [%e b]]]. *)
+val seq_reduce : ?sep:expression -> expression -> expression -> expression
+
+(** [binop_reduce] ≡ [fun x a b -> [%expr [%e x] [%e a] [%e b]]]. *)
+val binop_reduce : expression -> expression -> expression -> expression
+
+(** [strong_type_of_type ty] transform a type ty to
+    [freevars . ty], giving a strong polymorphic type *)
+val strong_type_of_type: core_type -> core_type
+
+(** The mapper for the currently loaded deriving plugins. It is useful for
+    recursively processing expression-valued attributes. *)
+val mapper : Ast_mapper.mapper
+
+(** {2 Miscellanea} *)
+
+(** [hash_variant x] ≡ [Btype.hash_variant x]. *)
+val hash_variant : string -> int
diff --git a/src/ppx_deriving_main.cppo.ml b/src/ppx_deriving_main.cppo.ml
new file mode 100644
index 0000000..1922a81
--- /dev/null
+++ b/src/ppx_deriving_main.cppo.ml
@@ -0,0 +1,54 @@
+#if OCAML_VERSION < (4, 03, 0)
+#define Pconst_string Const_string
+#endif
+
+open Asttypes
+open Parsetree
+open Ast_helper
+
+let raise_errorf = Ppx_deriving.raise_errorf
+
+let dynlink ?(loc=Location.none) filename =
+  let filename = Dynlink.adapt_filename filename in
+  try
+    Dynlink.loadfile filename
+  with Dynlink.Error error ->
+    raise_errorf ~loc "Cannot load %s: %s" filename (Dynlink.error_message error)
+
+let get_plugins () =
+  match Ast_mapper.get_cookie "ppx_deriving" with
+  | Some { pexp_desc = Pexp_tuple exprs } ->
+    exprs |> List.map (fun expr ->
+      match expr with
+      | { pexp_desc = Pexp_constant (Pconst_string (file, None)) } -> file
+      | _ -> assert false)
+  | Some _ -> assert false
+  | None -> []
+
+let add_plugins plugins =
+  let loaded  = get_plugins () in
+  let plugins = List.filter (fun file -> not (List.mem file loaded)) plugins in
+  List.iter dynlink plugins;
+  let loaded  = loaded @ plugins in
+  Ast_mapper.set_cookie "ppx_deriving"
+    (Exp.tuple (List.map (fun file -> Exp.constant (Pconst_string (file, None))) loaded))
+
+let mapper argv =
+  get_plugins () |> List.iter dynlink;
+  add_plugins argv;
+  let structure mapper = function
+    | [%stri [@@@findlib.ppxopt [%e? { pexp_desc = Pexp_tuple (
+          [%expr "ppx_deriving"] :: elems) }]]] :: rest ->
+      elems |>
+        List.map (fun elem ->
+          match elem with
+          | { pexp_desc = Pexp_constant (Pconst_string (file, None))} -> file
+          | _ -> assert false) |>
+        add_plugins;
+        mapper.Ast_mapper.structure mapper rest
+    | items -> Ppx_deriving.mapper.Ast_mapper.structure mapper items in
+  { Ppx_deriving.mapper with Ast_mapper.structure }
+
+let () =
+  Ast_mapper.register "ppx_deriving" mapper
+
diff --git a/src/ppx_deriving_main.mllib b/src/ppx_deriving_main.mllib
new file mode 100644
index 0000000..a5545ed
--- /dev/null
+++ b/src/ppx_deriving_main.mllib
@@ -0,0 +1 @@
+ppx_deriving_main
diff --git a/src/ppx_deriving_runtime.ml b/src/ppx_deriving_runtime.ml
new file mode 100644
index 0000000..c4c240e
--- /dev/null
+++ b/src/ppx_deriving_runtime.ml
@@ -0,0 +1,58 @@
+module Predef = struct
+  type _int = int
+  type _char = char
+  type _string = string
+  type _float = float
+  type _bool = bool
+  type _unit = unit
+  type _exn = exn
+  type 'a _array = 'a array
+  type 'a _list = 'a list
+  type 'a _option = 'a option = None | Some of 'a
+  type _nativeint = nativeint
+  type _int32 = int32
+  type _int64 = int64
+  type 'a _lazy_t = 'a lazy_t
+  type _bytes = bytes
+end
+
+type int = Predef._int
+type char = Predef._char
+type string = Predef._string
+type float = Predef._float
+type bool = Predef._bool
+type unit = Predef._unit
+type exn = Predef._exn
+type 'a array = 'a Predef._array
+type 'a list = 'a Predef._list
+type 'a option = 'a Predef._option = None | Some of 'a
+type nativeint = Predef._nativeint
+type int32 = Predef._int32
+type int64 = Predef._int64
+type 'a lazy_t = 'a Predef._lazy_t
+type bytes = Predef._bytes
+
+module Pervasives = Pervasives
+module Char = Char
+module String = String
+module Printexc = Printexc
+module Array = Array
+module List = List
+module Nativeint = Nativeint
+module Int32 = Int32
+module Int64 = Int64
+module Lazy = Lazy
+module Bytes = Bytes
+
+module Hashtbl = Hashtbl
+module Queue = Queue
+module Stack = Stack
+module Set = Set
+module Map = Map
+module Weak = Weak
+
+module Printf = Printf
+module Format = Format
+module Buffer = Buffer
+
+include Pervasives
diff --git a/src/ppx_deriving_runtime.mli b/src/ppx_deriving_runtime.mli
new file mode 100644
index 0000000..4481952
--- /dev/null
+++ b/src/ppx_deriving_runtime.mli
@@ -0,0 +1,101 @@
+(** A module collecting all predefined OCaml types, exceptions and
+    modules operating on them, so that ppx_deriving plugins operate
+    in a well-defined environment. *)
+
+(** {2 Predefined types} *)
+
+(** The {!Predef} module is necessary in absence of a [type nonrec]
+    construct. *)
+module Predef : sig
+  type _int = int
+  type _char = char
+  type _string = string
+  type _float = float
+  type _bool = bool (* = false | true *) (* see PR5936, GPR76, GPR234 *)
+  type _unit = unit (* = () *)
+  type _exn = exn
+  type 'a _array = 'a array
+  type 'a _list = 'a list (* = [] | 'a :: 'a list *)
+  type 'a _option = 'a option = None | Some of 'a
+  type _nativeint = nativeint
+  type _int32 = int32
+  type _int64 = int64
+  type 'a _lazy_t = 'a lazy_t
+  type _bytes = bytes
+end
+
+type int = Predef._int
+type char = Predef._char
+type string = Predef._string
+type float = Predef._float
+type bool = Predef._bool
+type unit = Predef._unit
+type exn = Predef._exn
+type 'a array = 'a Predef._array
+type 'a list = 'a Predef._list
+type 'a option = 'a Predef._option = None | Some of 'a
+type nativeint = Predef._nativeint
+type int32 = Predef._int32
+type int64 = Predef._int64
+type 'a lazy_t = 'a Predef._lazy_t
+type bytes = Predef._bytes
+
+(** {2 Predefined modules}
+    {3 Operations on predefined types} *)
+
+module Pervasives : (module type of Pervasives with
+  type fpclass = Pervasives.fpclass and
+  type in_channel = Pervasives.in_channel and
+  type out_channel = Pervasives.out_channel and
+  type open_flag = Pervasives.open_flag and
+  type 'a ref = 'a Pervasives.ref and
+  type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and
+  type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and
+  type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format)
+include (module type of Pervasives with
+  type fpclass = Pervasives.fpclass and
+  type in_channel = Pervasives.in_channel and
+  type out_channel = Pervasives.out_channel and
+  type open_flag = Pervasives.open_flag and
+  type 'a ref = 'a Pervasives.ref and
+  type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and
+  type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and
+  type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format)
+
+module Char : (module type of Char)
+module String : (module type of String)
+module Printexc : (module type of Printexc with
+  type raw_backtrace := Printexc.raw_backtrace and
+  type backtrace_slot := Printexc.backtrace_slot and
+  type location := Printexc.location)
+module Array : (module type of Array)
+module List : (module type of List)
+module Nativeint : (module type of Nativeint)
+module Int32 : (module type of Int32)
+module Int64 : (module type of Int64)
+module Lazy : (module type of Lazy)
+module Bytes : (module type of Bytes)
+
+(** {3 Data structures} *)
+
+module Hashtbl : (module type of Hashtbl with
+  type ('a, 'b) t := ('a, 'b) Hashtbl.t and
+  type statistics := Hashtbl.statistics)
+module Queue : (module type of Queue with
+  type 'a t := 'a Queue.t)
+module Stack : (module type of Stack with
+  type 'a t := 'a Stack.t)
+module Set : (module type of Set)
+module Map : (module type of Map)
+module Weak : (module type of Weak with
+  type 'a t := 'a Weak.t)
+module Buffer : (module type of Buffer with
+  type t := Buffer.t)
+
+(** {3 Formatting} *)
+
+module Printf : (module type of Printf)
+module Format : (module type of Format with
+  type formatter_out_functions := Format.formatter_out_functions and
+  type formatter_tag_functions := Format.formatter_tag_functions and
+  type formatter := Format.formatter)