Update metaquot to produce Ppx_ast types instead of Parsetree.

Also remove metaquot patterns in favor of ppx_view.

Author: ceastlund

ast/builder.ml

@@ -609,6 +609,13 @@ module Common = struct
   module Located = struct
     let longident ~loc longident = Astlib.Loc.create ~loc ~txt:longident ()
     let lident ~loc x = longident ~loc (Longident.lident x)
+
+    let dotted ~loc list =
+      match list with
+      | [] -> invalid_arg "Located.dotted: empty list"
+      | head :: tail ->
+        longident ~loc
+          (List.fold_left ~init:(Longident.lident head) tail ~f:Longident.ldot)
   end
 
   let echar ~loc x = pexp_constant ~loc (Constant.pconst_char x)
@@ -630,6 +637,8 @@ module Common = struct
   let efloat ~loc x =
     pexp_constant ~loc (Constant.pconst_float (Float.to_string x) None)
 
+  let evar ~loc x = pexp_ident ~loc (Located.lident ~loc x)
+
   let eunit ~loc =
     pexp_construct ~loc (Located.lident ~loc "()") None
 
@@ -657,6 +666,10 @@ module Common = struct
       fun_expr
       (List.map args ~f:(fun expr -> (Arg_label.nolabel, expr)))
 
+  let eabstract ~loc pats body =
+    List.fold_right pats ~init:body ~f:(fun pat body ->
+      pexp_fun ~loc Arg_label.nolabel None pat body)
+
   let pchar ~loc x = ppat_constant ~loc (Constant.pconst_char x)
 
   let pstring ~loc x = ppat_constant ~loc (Constant.pconst_string x None)

ast/builder.mli

@@ -1393,6 +1393,7 @@ module Common : sig
     val longident
       : loc: Astlib.Location.t -> Versions.longident -> Versions.longident Astlib.Loc.t
     val lident : loc: Astlib.Location.t -> string -> Versions.longident Astlib.Loc.t
+    val dotted : loc: Astlib.Location.t -> string list -> Versions.longident Astlib.Loc.t
   end
 
   val echar : loc: Astlib.Location.t -> char -> Versions.expression
@@ -1402,11 +1403,17 @@ module Common : sig
   val eint64 : loc: Astlib.Location.t -> int64 -> Versions.expression
   val enativeint : loc: Astlib.Location.t -> nativeint -> Versions.expression
   val efloat : loc: Astlib.Location.t -> float -> Versions.expression
+  val evar : loc: Astlib.Location.t -> string -> Versions.expression
   val eunit : loc: Astlib.Location.t -> Versions.expression
   val ebool : loc: Astlib.Location.t -> bool -> Versions.expression
   val enil : loc: Astlib.Location.t -> Versions.expression
   val elist : loc: Astlib.Location.t -> Versions.expression list -> Versions.expression
   val etuple : loc: Astlib.Location.t -> Versions.expression list -> Versions.expression
+  val eabstract
+    :  loc:Astlib.Location.t
+    -> Versions.pattern list
+    -> Versions.expression
+    -> Versions.expression
   val eapply :
     loc : Astlib.Location.t ->
     Versions.expression ->

ast/cinaps/dune

@@ -1,4 +1,5 @@
 (library
- (name ppx_ast_cinaps)
+ (name        ppx_ast_cinaps)
+ (public_name ppx.ast_cinaps)
  (libraries astlib stdppx ocaml-compiler-libs.shadow)
  (flags (:standard -open Ocaml_shadow -safe-string)))

ast/cinaps/gen_traverse.ml

@@ -401,6 +401,11 @@ module Lift = struct
   let res_type = Ml.tvar "res"
 
   let extra_methods () =
+    Ml.declare_method
+      ~virtual_:true
+      ~name:"node"
+      ~signature:"(string * int) option -> 'res -> 'res"
+      ();
     Ml.declare_method
       ~virtual_:true
       ~name:"record"
@@ -432,7 +437,7 @@ module Lift = struct
     let name_and_val var_name = Printf.sprintf "(%S, %s)" var_name var_name in
     Ml.list_lit (List.map ~f:name_and_val var_names)
 
-  let typ_arg ~value_kind =
+  let make_node_arg ~value_kind =
     match value_kind with
     | Abstract -> "None"
     | Ast_type { node_name; targs } ->
@@ -445,14 +450,17 @@ module Lift = struct
         ~f:(fun {var; recursive_call} ->
           Printf.sprintf "let %s = %s %s in" var recursive_call var)
     in
+    let node_arg = make_node_arg ~value_kind in
     let result =
       match kind with
-      | Kalias -> pattern
-      | Ktuple -> Printf.sprintf "self#tuple %s" (tuple_arg vars)
+      | Kalias ->
+        Printf.sprintf "self#node %s %s" node_arg pattern
+      | Ktuple ->
+        Printf.sprintf "self#node %s (self#tuple %s)" node_arg (tuple_arg vars)
       | Krecord ->
-        Printf.sprintf "self#record %s %s" (typ_arg ~value_kind) (record_arg vars)
+        Printf.sprintf "self#record %s %s" node_arg (record_arg vars)
       | Kconstr name ->
-        Printf.sprintf "self#constr %s %S %s" (typ_arg ~value_kind) name (tuple_arg vars)
+        Printf.sprintf "self#constr %s %S %s" node_arg name (tuple_arg vars)
     in
     recurse @ [result]
 

ast/cinaps/ml.ml

@@ -6,24 +6,10 @@ let is_keyword s =
 let map_keyword s =
   if is_keyword s then s ^ "_" else s
 
-let is_id_char = function
-  | 'A' .. 'Z' -> true
-  | 'a' .. 'z' -> true
-  | '0' .. '9' -> true
-  | '_' | '\'' -> true
-  | _ -> false
-
-let to_id_char char =
-  if is_id_char char
-  then char
-  else '_'
-
-let raw_id string = String.map string ~f:to_id_char
-
-let id string = map_keyword (String.lowercase_ascii (raw_id string))
+let id string = map_keyword (String.lowercase_ascii string)
 let tvar string = "'" ^ id string
-let module_name string = String.capitalize_ascii (raw_id string)
-let tag string = String.capitalize_ascii (raw_id string)
+let module_name string = String.capitalize_ascii string
+let tag string = String.capitalize_ascii string
 
 let list_lit elms =
   Printf.sprintf "[%s]" (String.concat ~sep:"; " elms)

ast/traverse_builtins.ml

@@ -253,6 +253,7 @@ class virtual ['res] lift =
     method virtual nativeint :     (nativeint, 'res) T.lift
     method virtual unit      :     (unit,      'res) T.lift
 
+    method virtual node : (string * int) option -> 'res -> 'res
     method virtual record : (string * int) option -> (string * 'res) list -> 'res
     method virtual constr : (string * int) option -> string -> 'res list -> 'res
     method virtual tuple : 'res list -> 'res
@@ -300,6 +301,7 @@ class type ['res] std_lifters =
     method bool      : (bool ,     'res) T.lift
     method char      : (char ,     'res) T.lift
     method array     : 'a. ('a,    'res) T.lift -> ('a array, 'res) T.lift
+    method node      : (string * int) option ->             'res       -> 'res
     method record    : (string * int) option -> (string *   'res) list -> 'res
     method constr    : (string * int) option -> string ->   'res  list -> 'res
     method tuple     : 'res list   ->    'res

ast/traverse_builtins.mli

@@ -94,6 +94,7 @@ class virtual ['res] lift :
     method virtual int64     :     (int64,     'res) T.lift
     method virtual nativeint :     (nativeint, 'res) T.lift
     method virtual unit      :     (unit,      'res) T.lift
+    method virtual node : (string * int) option -> 'res -> 'res
     method virtual record : (string * int) option -> (string * 'res) list -> 'res
     method virtual constr : (string * int) option -> string -> 'res list -> 'res
     method virtual tuple : 'res list -> 'res
@@ -112,6 +113,7 @@ class type ['res] std_lifters =
     method bool      : (bool ,     'res) T.lift
     method char      : (char ,     'res) T.lift
     method array     : 'a. ('a,    'res) T.lift -> ('a array, 'res) T.lift
+    method node      : (string * int) option ->             'res       -> 'res
     method record    : (string * int) option -> (string *   'res) list -> 'res
     method constr    : (string * int) option -> string ->   'res  list -> 'res
     method tuple     : 'res list   ->    'res

ast/versions.ml

@@ -150,7 +150,7 @@ type label = string
 type longident_loc = longident Astlib.Loc.t
 
 module Unstable_for_testing = struct
-  let version = "unstable-for-testing"
+  let version = "unstable_for_testing"
   let node name data = Node.of_node ~version { name; data }
 
   module Directive_argument = struct
@@ -4675,7 +4675,7 @@ module Unstable_for_testing = struct
 end
 
 module V4_07 = struct
-  let version = "v4.07"
+  let version = "v4_07"
   let node name data = Node.of_node ~version { name; data }
 
   module Longident = struct