Upgrade to ppxlib 0.36.0 (#1887)

* Upgrade to ppxlib 0.36.0

Signed-off-by: Sora Morimoto <[email protected]>

* Add compatibility cases for wrapped `Pexp_function` expressions

Signed-off-by: Sora Morimoto <[email protected]>

* Fix `Pexp_function` pattern matching for compatibility with older parsetrees

Signed-off-by: Sora Morimoto <[email protected]>

---------

Signed-off-by: Sora Morimoto <[email protected]>

Author: smorimoto

dune-project

@@ -40,9 +40,7 @@
   (ocaml-version
    (>= 4.0))
   (ppxlib
-   (and
-    (>= 0.35)
-    (< 0.36)))
+   (>= 0.36))
   (opam-file-format
    (>= 2.1.6))
   (ocamlformat

src/ppx_tools/traverse_ast.ml

@@ -231,7 +231,7 @@ class virtual ['res] lift =
           self#constr "Ptyp_class" [ "longident_loc", a; "core_type list", b ]
         | Ptyp_alias (a, b) ->
           let a = self#core_type a in
-          let b = self#string b in
+          let b = self#loc self#string b in
           self#constr "Ptyp_alias" [ "core_type", a; "label", b ]
         | Ptyp_variant (a, b, c) ->
           let a = self#list self#row_field a in
@@ -250,6 +250,10 @@ class virtual ['res] lift =
         | Ptyp_extension a ->
           let a = self#extension a in
           self#constr "Ptyp_extension" [ "extension", a ]
+        | Ptyp_open (a, b) ->
+          let a = self#longident_loc a in
+          let b = self#core_type b in
+          self#constr "Ptyp_open" [ "longident_loc", a; "core_type", b ]
 
     method package_type : package_type -> 'res =
       fun (a, b) ->
@@ -429,17 +433,13 @@ class virtual ['res] lift =
           self#constr
             "Pexp_let"
             [ "rec_flag", a; "value_binding list", b; "expression", c ]
-        | Pexp_function a ->
-          let a = self#cases a in
-          self#constr "Pexp_function" [ "cases", a ]
-        | Pexp_fun (a, b, c, d) ->
-          let a = self#arg_label a in
-          let b = self#option self#expression b in
-          let c = self#pattern c in
-          let d = self#expression d in
+        | Pexp_function (a, b, c) ->
+          let a = self#list self#function_param a in
+          let b = self#option self#type_constraint b in
+          let c = self#function_body c in
           self#constr
-            "Pexp_fun"
-            [ "arg_label", a; "expression option", b; "pattern", c; "expression", d ]
+            "Pexp_function"
+            [ "function_param list", a; "type_constraint option", b; "function_body", c ]
         | Pexp_apply (a, b) ->
           let a = self#expression a in
           let b =
@@ -1371,6 +1371,9 @@ class virtual ['res] lift =
         | Pmod_extension a ->
           let a = self#extension a in
           self#constr "Pmod_extension" [ "extension", a ]
+        | Pmod_apply_unit a ->
+          let a = self#module_expr a in
+          self#constr "Pmod_apply_unit" [ "module_expr", a ]
 
     method structure : structure -> 'res = self#list self#structure_item
 
@@ -1434,17 +1437,19 @@ class virtual ['res] lift =
           self#constr "Pstr_extension" [ "extension", a; "attributes", b ]
 
     method value_binding : value_binding -> 'res =
-      fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } ->
+      fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint } ->
         let pvb_pat = self#pattern pvb_pat in
         let pvb_expr = self#expression pvb_expr in
         let pvb_attributes = self#attributes pvb_attributes in
         let pvb_loc = self#location pvb_loc in
+        let pvb_constraint = self#option self#value_constraint pvb_constraint in
         self#record
           "value_binding"
           [ "pvb_pat", pvb_pat
           ; "pvb_expr", pvb_expr
           ; "pvb_attributes", pvb_attributes
           ; "pvb_loc", pvb_loc
+          ; "pvb_constraint", pvb_constraint
           ]
 
     method module_binding : module_binding -> 'res =
@@ -1506,4 +1511,65 @@ class virtual ['res] lift =
           self#constr "Pdir_bool" [ "bool", a ]
 
     method cases : cases -> 'res = self#list self#case
+
+    method function_param : function_param -> 'res =
+      fun { pparam_loc; pparam_desc } ->
+        let pparam_loc = self#location pparam_loc in
+        let pparam_desc = self#function_param_desc pparam_desc in
+        self#record
+          "function_param"
+          [ "pparam_loc", pparam_loc; "pparam_desc", pparam_desc ]
+
+    method function_param_desc : function_param_desc -> 'res =
+      fun x ->
+        match x with
+        | Pparam_val (a, b, c) ->
+          let a = self#arg_label a in
+          let b = self#option self#expression b in
+          let c = self#pattern c in
+          self#constr
+            "Pparam_val"
+            [ "arg_label", a; "expression option", b; "pattern", c ]
+        | Pparam_newtype a ->
+          let a = self#loc self#string a in
+          self#constr "Pparam_newtype" [ "string loc", a ]
+
+    method type_constraint : type_constraint -> 'res =
+      fun x ->
+        match x with
+        | Pconstraint a ->
+          let a = self#core_type a in
+          self#constr "Pconstraint" [ "core_type", a ]
+        | Pcoerce (a, b) ->
+          let a = self#option self#core_type a in
+          let b = self#core_type b in
+          self#constr "Pcoerce" [ "core_type option", a; "core_type", b ]
+
+    method value_constraint : value_constraint -> 'res =
+      fun x ->
+        match x with
+        | Pvc_constraint { locally_abstract_univars; typ } ->
+          let locally_abstract_univars =
+            self#list (self#loc self#string) locally_abstract_univars
+          in
+          let typ = self#core_type typ in
+          self#constr
+            "Pvc_constraint"
+            [ "locally_abstract_univars", locally_abstract_univars; "typ", typ ]
+        | Pvc_coercion { ground; coercion } ->
+          let ground = self#option self#core_type ground in
+          let coercion = self#core_type coercion in
+          self#constr "Pvc_coercion" [ "ground", ground; "coercion", coercion ]
+
+    method function_body : function_body -> 'res =
+      fun x ->
+        match x with
+        | Pfunction_body a ->
+          let a = self#expression a in
+          self#constr "Pfunction_body" [ "expression", a ]
+        | Pfunction_cases (a, b, c) ->
+          let a = self#cases a in
+          let b = self#location b in
+          let c = self#attributes c in
+          self#constr "Pfunction_cases" [ "cases", a; "location", b; "attributes", c ]
   end

src/ppx_tools/traverse_ast2.ml

@@ -312,7 +312,7 @@ class virtual ['res] lift2 =
           self#constr "Ptyp_class" [ "longident_loc", a; "core_type list", b ]
         | Ptyp_alias (a, b), Ptyp_alias (a', b') ->
           let a = self#core_type a a' in
-          let b = self#string b b' in
+          let b = self#loc self#string b b' in
           self#constr "Ptyp_alias" [ "core_type", a; "label", b ]
         | Ptyp_variant (a, b, c), Ptyp_variant (a', b', c') ->
           let a = self#list self#row_field a a' in
@@ -331,6 +331,10 @@ class virtual ['res] lift2 =
         | Ptyp_extension a, Ptyp_extension a' ->
           let a = self#extension a a' in
           self#constr "Ptyp_extension" [ "extension", a ]
+        | Ptyp_open (a, b), Ptyp_open (a', b') ->
+          let a = self#longident_loc a a' in
+          let b = self#core_type b b' in
+          self#constr "Ptyp_open" [ "longident_loc", a; "core_type", b ]
         | _ -> Error "core_type_desc"
 
     method package_type : package_type -> package_type -> ('res, string) result =
@@ -532,17 +536,13 @@ class virtual ['res] lift2 =
           self#constr
             "Pexp_let"
             [ "rec_flag", a; "value_binding list", b; "expression", c ]
-        | Pexp_function a, Pexp_function a' ->
-          let a = self#cases a a' in
-          self#constr "Pexp_function" [ "cases", a ]
-        | Pexp_fun (a, b, c, d), Pexp_fun (a', b', c', d') ->
-          let a = self#arg_label a a' in
-          let b = self#option self#expression b b' in
-          let c = self#pattern c c' in
-          let d = self#expression d d' in
+        | Pexp_function (a, b, c), Pexp_function (a', b', c') ->
+          let a = self#list self#function_param a a' in
+          let b = self#option self#type_constraint b b' in
+          let c = self#function_body c c' in
           self#constr
-            "Pexp_fun"
-            [ "arg_label", a; "expression option", b; "pattern", c; "expression", d ]
+            "Pexp_function"
+            [ "function_param list", a; "type_constraint option", b; "function_body", c ]
         | Pexp_apply (a, b), Pexp_apply (a', b') ->
           let a = self#expression a a' in
           let b =
@@ -741,37 +741,34 @@ class virtual ['res] lift2 =
           self#constr
             "Pexp_let"
             [ "rec_flag", a; "value_binding list", b; "expression", c ]
-        (*Caused by: [fun (t39 : t39 Js_of_ocaml.Js.t) -> ...] *)
-        | ( Pexp_fun (a, b, c, d)
-          , Pexp_apply ({ pexp_desc = Pexp_fun (a', b', c', d'); _ }, _) ) ->
-          let a = self#arg_label a a' in
-          let b = self#option self#expression b b' in
-          let c = self#pattern c c' in
-          let d = self#expression d d' in
+        (*Caused by: [function param -> ...] when wrapped in Pexp_apply *)
+        | ( Pexp_function ((_ :: _ as a), b, c)
+          , Pexp_apply ({ pexp_desc = Pexp_function ((_ :: _ as a'), b', c'); _ }, _) ) ->
+          let a = self#list self#function_param a a' in
+          let b = self#option self#type_constraint b b' in
+          let c = self#function_body c c' in
           self#constr
-            "Pexp_fun"
-            [ "arg_label", a; "expression option", b; "pattern", c; "expression", d ]
-        (*Caused by: [fun x -> Ppx_deriving_runtime.Format.asprintf "%a" pp x] *)
-        | ( Pexp_fun (a, b, c, d)
-          , Pexp_constraint ({ pexp_desc = Pexp_fun (a', b', c', d'); _ }, _) ) ->
-          let a = self#arg_label a a' in
-          let b = self#option self#expression b b' in
-          let c = self#pattern c c' in
-          let d = self#expression d d' in
+            "Pexp_function"
+            [ "function_param list", a; "type_constraint option", b; "function_body", c ]
+        (*Caused by: [function param -> ...] when wrapped in Pexp_constraint *)
+        | ( Pexp_function ((_ :: _ as a), b, c)
+          , Pexp_constraint ({ pexp_desc = Pexp_function ((_ :: _ as a'), b', c'); _ }, _)
+          ) ->
+          let a = self#list self#function_param a a' in
+          let b = self#option self#type_constraint b b' in
+          let c = self#function_body c c' in
           self#constr
-            "Pexp_fun"
-            [ "arg_label", a; "expression option", b; "pattern", c; "expression", d ]
-        (* Caused by: {[ fun env -> fun _visitors_this_0 -> fun _visitors_this_1
-           -> ]} in opams package morbig/src/CST for instance *)
-        | ( Pexp_fun (a, b, c, d)
-          , Pexp_poly ({ pexp_desc = Pexp_fun (a', b', c', d'); _ }, _) ) ->
-          let a = self#arg_label a a' in
-          let b = self#option self#expression b b' in
-          let c = self#pattern c c' in
-          let d = self#expression d d' in
+            "Pexp_function"
+            [ "function_param list", a; "type_constraint option", b; "function_body", c ]
+        (*Caused by: [function param -> ...] when wrapped in Pexp_poly *)
+        | ( Pexp_function ((_ :: _ as a), b, c)
+          , Pexp_poly ({ pexp_desc = Pexp_function ((_ :: _ as a'), b', c'); _ }, _) ) ->
+          let a = self#list self#function_param a a' in
+          let b = self#option self#type_constraint b b' in
+          let c = self#function_body c c' in
           self#constr
-            "Pexp_fun"
-            [ "arg_label", a; "expression option", b; "pattern", c; "expression", d ]
+            "Pexp_function"
+            [ "function_param list", a; "type_constraint option", b; "function_body", c ]
         (* Caused by this recurent piece of code: {[ ((fun (type res) -> fun
            (type t9) -> fun (type t8) -> fun (t9 : t9 Js_of_ocaml.Js.t) -> fun
            (t8 : t8) -> fun (_ : t9 -> < set: t8 -> unit ;.. >
@@ -1748,6 +1745,9 @@ class virtual ['res] lift2 =
         | Pmod_extension a, Pmod_extension a' ->
           let a = self#extension a a' in
           self#constr "Pmod_extension" [ "extension", a ]
+        | Pmod_apply_unit a, Pmod_apply_unit a' ->
+          let a = self#module_expr a a' in
+          self#constr "Pmod_apply_unit" [ "module_expr", a ]
         | _ -> Error "module_expr_desc"
 
     method structure : structure -> structure -> ('res, string) result =
@@ -1815,22 +1815,27 @@ class virtual ['res] lift2 =
         | _ -> Error "structure_item_desc"
 
     method value_binding : value_binding -> value_binding -> ('res, string) result =
-      fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc }
+      fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint }
         { pvb_pat = pvb_pat'
         ; pvb_expr = pvb_expr'
         ; pvb_attributes = pvb_attributes'
         ; pvb_loc = pvb_loc'
+        ; pvb_constraint = pvb_constraint'
         } ->
         let pvb_pat = self#pattern pvb_pat pvb_pat' in
         let pvb_expr = self#expression pvb_expr pvb_expr' in
         let pvb_attributes = self#attributes pvb_attributes pvb_attributes' in
         let pvb_loc = self#location pvb_loc pvb_loc' in
+        let pvb_constraint =
+          self#option self#value_constraint pvb_constraint pvb_constraint'
+        in
         self#record
           "value_binding"
           [ "pvb_pat", pvb_pat
           ; "pvb_expr", pvb_expr
           ; "pvb_attributes", pvb_attributes
           ; "pvb_loc", pvb_loc
+          ; "pvb_constraint", pvb_constraint
           ]
 
     method module_binding : module_binding -> module_binding -> ('res, string) result =
@@ -1904,4 +1909,78 @@ class virtual ['res] lift2 =
         | _ -> Error "directive_argument_desc"
 
     method cases : cases -> cases -> ('res, string) result = self#list self#case
+
+    method function_param : function_param -> function_param -> ('res, string) result =
+      fun { pparam_loc; pparam_desc }
+        { pparam_loc = pparam_loc'; pparam_desc = pparam_desc' } ->
+        let pparam_loc = self#location pparam_loc pparam_loc' in
+        let pparam_desc = self#function_param_desc pparam_desc pparam_desc' in
+        self#record
+          "function_param"
+          [ "pparam_loc", pparam_loc; "pparam_desc", pparam_desc ]
+
+    method function_param_desc
+      : function_param_desc -> function_param_desc -> ('res, string) result =
+      fun x x' ->
+        match x, x' with
+        | Pparam_val (a, b, c), Pparam_val (a', b', c') ->
+          let a = self#arg_label a a' in
+          let b = self#option self#expression b b' in
+          let c = self#pattern c c' in
+          self#constr
+            "Pparam_val"
+            [ "arg_label", a; "expression option", b; "pattern", c ]
+        | Pparam_newtype a, Pparam_newtype a' ->
+          let a = self#loc self#string a a' in
+          self#constr "Pparam_newtype" [ "string loc", a ]
+        | _ -> Error "function_param_desc"
+
+    method type_constraint : type_constraint -> type_constraint -> ('res, string) result =
+      fun x x' ->
+        match x, x' with
+        | Pconstraint a, Pconstraint a' ->
+          let a = self#core_type a a' in
+          self#constr "Pconstraint" [ "core_type", a ]
+        | Pcoerce (a, b), Pcoerce (a', b') ->
+          let a = self#option self#core_type a a' in
+          let b = self#core_type b b' in
+          self#constr "Pcoerce" [ "core_type option", a; "core_type", b ]
+        | _ -> Error "type_constraint"
+
+    method value_constraint
+      : value_constraint -> value_constraint -> ('res, string) result =
+      fun x x' ->
+        match x, x' with
+        | ( Pvc_constraint { locally_abstract_univars; typ }
+          , Pvc_constraint
+              { locally_abstract_univars = locally_abstract_univars'; typ = typ' } ) ->
+          let locally_abstract_univars =
+            self#list
+              (self#loc self#string)
+              locally_abstract_univars
+              locally_abstract_univars'
+          in
+          let typ = self#core_type typ typ' in
+          self#constr
+            "Pvc_constraint"
+            [ "locally_abstract_univars", locally_abstract_univars; "typ", typ ]
+        | ( Pvc_coercion { ground; coercion }
+          , Pvc_coercion { ground = ground'; coercion = coercion' } ) ->
+          let ground = self#option self#core_type ground ground' in
+          let coercion = self#core_type coercion coercion' in
+          self#constr "Pvc_coercion" [ "ground", ground; "coercion", coercion ]
+        | _ -> Error "value_constraint"
+
+    method function_body : function_body -> function_body -> ('res, string) result =
+      fun x x' ->
+        match x, x' with
+        | Pfunction_body a, Pfunction_body a' ->
+          let a = self#expression a a' in
+          self#constr "Pfunction_body" [ "expression", a ]
+        | Pfunction_cases (a, b, c), Pfunction_cases (a', b', c') ->
+          let a = self#cases a a' in
+          let b = self#location b b' in
+          let c = self#attributes c c' in
+          self#constr "Pfunction_cases" [ "cases", a; "location", b; "attributes", c ]
+        | _ -> Error "function_body"
   end

vscode-ocaml-platform.opam

@@ -25,7 +25,7 @@ depends: [
   "promise_jsoo" {>= "0.4.3"}
   "jsonoo" {>= "0.3"}
   "ocaml-version" {>= "4.0"}
-  "ppxlib" {>= "0.35" & < "0.36"}
+  "ppxlib" {>= "0.36"}
   "opam-file-format" {>= "2.1.6"}
   "ocamlformat" {= "0.27.0" & with-dev-setup}
   "ocaml-lsp-server" {with-dev-setup}