Support 4.10 ASTs (#25)

Resolves #23.

Author: aantron

ast_convenience_410.ml

@@ -0,0 +1,124 @@
+open Migrate_parsetree.Ast_410
+
+(*  This file is part of the ppx_tools package.  It is released  *)
+(*  under the terms of the MIT license (see LICENSE file).       *)
+(*  Copyright 2013  Alain Frisch and LexiFi                      *)
+
+open Parsetree
+open Asttypes
+open Location
+open Ast_helper
+
+
+module Label = struct
+
+  type t = Asttypes.arg_label
+
+  type desc = Asttypes.arg_label =
+      Nolabel
+    | Labelled of string
+    | Optional of string
+
+  let explode x = x
+
+  let nolabel = Nolabel
+  let labelled x = Labelled x
+  let optional x = Optional x
+
+end
+
+module Constant = struct
+  type t = Parsetree.constant =
+     Pconst_integer of string * char option
+   | Pconst_char of char
+   | Pconst_string of string * string option
+   | Pconst_float of string * char option
+
+  let of_constant x = x
+
+  let to_constant x = x
+
+end
+
+let may_tuple ?loc tup = function
+  | [] -> None
+  | [x] -> Some x
+  | l -> Some (tup ?loc ?attrs:None l)
+
+let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc
+let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args)
+let nil ?loc ?attrs () = constr ?loc ?attrs "[]" []
+let unit ?loc ?attrs () = constr ?loc ?attrs "()" []
+let tuple ?loc ?attrs = function
+  | [] -> unit ?loc ?attrs ()
+  | [x] -> x
+  | xs -> Exp.tuple ?loc ?attrs xs
+let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl]
+let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ())
+let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None))
+let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None))
+let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l'))
+let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L'))
+let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x)
+let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None))
+let record ?loc ?attrs ?over l =
+  Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over
+let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l)
+let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp
+let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l)
+let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s)
+let let_in ?loc ?attrs ?(recursive = false) b body =
+  Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body
+
+let sequence ?loc ?attrs = function
+  | [] -> unit ?loc ?attrs ()
+  | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl
+
+let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc)
+let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args)
+let precord ?loc ?attrs ?(closed = Open) l =
+  Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed
+let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" []
+let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl]
+let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" []
+let ptuple ?loc ?attrs = function
+  | [] -> punit ?loc ?attrs ()
+  | [x] -> x
+  | xs -> Pat.tuple ?loc ?attrs xs
+let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ())
+
+let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None))
+let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None))
+let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x)
+let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None))
+
+let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l
+
+let get_str = function
+  | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s
+  | _ -> None
+
+let get_str_with_quotation_delimiter = function
+  | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d)
+  | _ -> None
+
+let get_lid = function
+  | {pexp_desc=Pexp_ident{txt=id;_};_} ->
+      Some (String.concat "." (Longident.flatten id))
+  | _ -> None
+
+let find_attr s attrs =
+  try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload)
+  with Not_found -> None
+
+let expr_of_payload = function
+  | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e
+  | _ -> None
+
+let find_attr_expr s attrs =
+  match find_attr s attrs with
+  | Some e -> expr_of_payload e
+  | None -> None
+
+let has_attr s attrs =
+  find_attr s attrs <> None

ast_convenience_410.mli

@@ -0,0 +1,112 @@
+open Migrate_parsetree.Ast_410
+
+(*  This file is part of the ppx_tools package.  It is released  *)
+(*  under the terms of the MIT license (see LICENSE file).       *)
+(*  Copyright 2013  Alain Frisch and LexiFi                      *)
+
+(** {1 Convenience functions to help build and deconstruct AST fragments.} *)
+
+open Asttypes
+open Ast_helper
+open Parsetree
+
+(** {2 Compatibility modules} *)
+
+module Label : sig
+  type t = Asttypes.arg_label
+
+  type desc = Asttypes.arg_label =
+      Nolabel
+    | Labelled of string
+    | Optional of string
+
+  val explode : t -> desc
+
+  val nolabel : t
+  val labelled : string -> t
+  val optional : string -> t
+
+end
+
+(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant
+ * types defined in ocaml 4.03 and 4.02 respectively}*)
+module Constant : sig
+  type t = Parsetree.constant =
+     Pconst_integer of string * char option
+   | Pconst_char of char
+   | Pconst_string of string * string option
+   | Pconst_float of string * char option
+
+  (** Convert Asttypes.constant to Constant.t *)
+  val of_constant : Parsetree.constant -> t
+
+  (** Convert Constant.t to Asttypes.constant *)
+  val to_constant : t -> Parsetree.constant
+
+end
+
+(** {2 Misc} *)
+
+val lid: ?loc:loc -> string -> lid
+
+(** {2 Expressions} *)
+
+val evar: ?loc:loc -> ?attrs:attrs -> string -> expression
+val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression
+
+val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression
+val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression
+val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+
+val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression
+val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
+val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+
+val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression
+
+val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression
+val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression
+val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression
+
+val str: ?loc:loc -> ?attrs:attrs -> string -> expression
+val int: ?loc:loc -> ?attrs:attrs -> int -> expression
+val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression
+val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression
+val char: ?loc:loc -> ?attrs:attrs -> char -> expression
+val float: ?loc:loc -> ?attrs:attrs -> float -> expression
+
+val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+(** Return [()] if the list is empty. Tail rec. *)
+
+(** {2 Patterns} *)
+
+val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern
+val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern
+val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern
+val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+
+val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
+val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+
+val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern
+val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern
+val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern
+val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern
+
+val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern
+
+
+(** {2 Types} *)
+
+val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type
+
+(** {2 AST deconstruction} *)
+
+val get_str: expression -> string option
+val get_str_with_quotation_delimiter: expression -> (string * string option) option
+val get_lid: expression -> string option
+
+val has_attr: string -> attributes -> bool
+val find_attr: string -> attributes -> payload option
+val find_attr_expr: string -> attributes -> expression option