Bump internal AST to 4.10

.travis.yml

@@ -15,5 +15,9 @@ env:
   - OCAML_VERSION="4.06"
     TESTS=false
   - OCAML_VERSION="4.07"
+    TEST=false
   - OCAML_VERSION="4.08"
+    TEST=false
   - OCAML_VERSION="4.09"
+    TEST=false
+  - OCAML_VERSION="4.10"

appveyor.yml

@@ -9,24 +9,46 @@ environment:
   matrix:
   - OPAM_SWITCH: 4.04.2+mingw64c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.04.2+mingw32c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.05.0+mingw64c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.05.0+mingw32c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.06.0+mingw64c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.06.0+mingw32c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.07.1+mingw64c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.07.1+mingw32c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.08.0+mingw64c
     PACKAGE: ppxlib
+    TESTS: false
   - OPAM_SWITCH: 4.08.0+mingw32c
     PACKAGE: ppxlib
+    TESTS: false
+  - OPAM_SWITCH: 4.09.0+mingw64c
+    PACKAGE: ppxlib
+    TESTS: false
+  - OPAM_SWITCH: 4.09.0+mingw32c
+    PACKAGE: ppxlib
+    TESTS: false
+  - OPAM_SWITCH: 4.10.0+mingw64c
+    PACKAGE: ppxlib
+    TESTS: false
+  - OPAM_SWITCH: 4.10.0+mingw32c
+    PACKAGE: ppxlib
+    TESTS: false
 install:
 - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1"))
 build_script:

ast/import.ml

@@ -4,7 +4,7 @@
    It must be opened in all modules, especially the ones coming from the compiler.
 *)
 
-module Js    = Migrate_parsetree.OCaml_408
+module Js    = Migrate_parsetree.OCaml_410
 module Ocaml = Migrate_parsetree.Versions.OCaml_current
 
 module Select_ast(Ocaml : Migrate_parsetree.Versions.OCaml_version) = struct

ast/pprintast.ml

@@ -443,8 +443,10 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
     | Ppat_var ({txt = txt;_}) -> protect_ident f txt
     | Ppat_array l ->
         pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
-    | Ppat_unpack (s) ->
-        pp f "(module@ %s)@ " s.txt
+    | Ppat_unpack { txt = None } ->
+        pp f "(module@ _)@ "
+    | Ppat_unpack { txt= Some s } ->
+        pp f "(module@ %s)@ " s
     | Ppat_type li ->
         pp f "#%a" longident_loc li
     | Ppat_record (l, closed) ->
@@ -695,7 +697,8 @@ and expression ctxt f x =
         pp f "@[<hov2>{<%a>}@]"
           (list string_x_expression  ~sep:";"  )  l;
     | Pexp_letmodule (s, me, e) ->
-        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
+        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
+          (match s.txt with None -> "_" | Some s -> s)
           (module_expr reset_ctxt) me (expression ctxt) e
     | Pexp_letexception (cd, e) ->
         pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
@@ -1018,15 +1021,17 @@ and module_type ctxt f x =
       (attributes ctxt) x.pmty_attributes
   end else
     match x.pmty_desc with
-    | Pmty_functor (_, None, mt2) ->
+    | Pmty_functor (Unit, mt2) ->
         pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
-    | Pmty_functor (s, Some mt1, mt2) ->
-        if s.txt = "_" then
-          pp f "@[<hov2>%a@ ->@ %a@]"
-            (module_type1 ctxt) mt1 (module_type ctxt) mt2
-        else
-          pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
-            (module_type ctxt) mt1 (module_type ctxt) mt2
+    | Pmty_functor (Named (s, mt1), mt2) ->
+        begin match s.txt with
+        | None ->
+            pp f "@[<hov2>%a@ ->@ %a@]"
+              (module_type1 ctxt) mt1 (module_type ctxt) mt2
+        | Some name ->
+            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
+              (module_type ctxt) mt1 (module_type ctxt) mt2
+        end
     | Pmty_with (mt, []) -> module_type ctxt f mt
     | Pmty_with (mt, l) ->
         let with_constraint f = function
@@ -1100,12 +1105,13 @@ and signature_item ctxt f x : unit =
       end
   | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
                             pmty_attributes=[]; _};_} as pmd) ->
-      pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
+      pp f "@[<hov>module@ %s@ =@ %a@]%a"
+        (match pmd.pmd_name.txt with None -> "_" | Some s -> s)
         longident_loc alias
         (item_attributes ctxt) pmd.pmd_attributes
   | Psig_module pmd ->
       pp f "@[<hov>module@ %s@ :@ %a@]%a"
-        pmd.pmd_name.txt
+        (match pmd.pmd_name.txt with None -> "_" | Some s -> s)
         (module_type ctxt) pmd.pmd_type
         (item_attributes ctxt) pmd.pmd_attributes
   | Psig_modsubst pms ->
@@ -1138,11 +1144,13 @@ and signature_item ctxt f x : unit =
         | [] -> () ;
         | pmd :: tl ->
             if not first then
-              pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
+                (match pmd.pmd_name.txt with None -> "_" | Some s -> s)
                 (module_type1 ctxt) pmd.pmd_type
                 (item_attributes ctxt) pmd.pmd_attributes
             else
-              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
+                (match pmd.pmd_name.txt with None -> "_" | Some s -> s)
                 (module_type1 ctxt) pmd.pmd_type
                 (item_attributes ctxt) pmd.pmd_attributes;
             string_x_module_type_list f ~first:false tl
@@ -1167,11 +1175,12 @@ and module_expr ctxt f x =
           (module_type ctxt) mt
     | Pmod_ident (li) ->
         pp f "%a" longident_loc li;
-    | Pmod_functor (_, None, me) ->
+    | Pmod_functor (Unit, me) ->
         pp f "functor ()@;->@;%a" (module_expr ctxt) me
-    | Pmod_functor (s, Some mt, me) ->
+    | Pmod_functor (Named (s, mt), me) ->
         pp f "functor@ (%s@ :@ %a)@;->@;%a"
-          s.txt (module_type ctxt) mt (module_expr ctxt) me
+          (match s.txt with None -> "_" | Some s -> s)
+          (module_type ctxt) mt (module_expr ctxt) me
     | Pmod_apply (me1, me2) ->
         pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
         (* Cf: #7200 *)
@@ -1296,14 +1305,19 @@ and structure_item ctxt f x =
   | Pstr_exception ed -> exception_declaration ctxt f ed
   | Pstr_module x ->
       let rec module_helper = function
-        | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
-            if mt = None then pp f "()"
-            else Misc_helper.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
+        | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
+            begin match arg_opt with
+            | Unit -> pp f "()"
+            | Named (s, mt) ->
+              pp f "(%s:%a)"
+                (match s.txt with None -> "_" | Some s -> s)
+                (module_type ctxt) mt
+            end;
             module_helper me'
         | me -> me
       in
       pp f "@[<hov2>module %s%a@]%a"
-        x.pmb_name.txt
+        (match x.pmb_name.txt with None -> "_" | Some s -> s)
         (fun f me ->
            let me = module_helper me in
            match me with
@@ -1382,20 +1396,31 @@ and structure_item ctxt f x =
   | Pstr_recmodule decls -> (* 3.07 *)
       let aux f = function
         | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
-            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
+              (match pmb.pmb_name.txt with None -> "_" | Some s -> s)
               (module_type ctxt) typ
               (module_expr ctxt) expr
               (item_attributes ctxt) pmb.pmb_attributes
-        | _ -> assert false
+        | pmb ->
+            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
+              (match pmb.pmb_name.txt with None -> "_" | Some s -> s)
+              (module_expr ctxt) pmb.pmb_expr
+              (item_attributes ctxt) pmb.pmb_attributes
       in
       begin match decls with
       | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
           pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
-            pmb.pmb_name.txt
+            (match pmb.pmb_name.txt with None -> "_" | Some s -> s)
             (module_type ctxt) typ
             (module_expr ctxt) expr
             (item_attributes ctxt) pmb.pmb_attributes
             (fun f l2 -> List.iter (aux f) l2) l2
+      | pmb :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
+            (match pmb.pmb_name.txt with None -> "_" | Some s -> s)
+            (module_expr ctxt) pmb.pmb_expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
       | _ -> assert false
       end
   | Pstr_attribute a -> floating_attribute ctxt f a

ppxlib.opam

@@ -11,14 +11,14 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 run-test: [
-  ["dune" "runtest" "-p" name "-j" jobs] { ocaml:version >= "4.06" & ocaml:version < "4.08" }
+  ["dune" "runtest" "-p" name "-j" jobs] { ocaml:version >= "4.10" }
 ]
 depends: [
   "ocaml"                   {>= "4.04.1"}
   "base"                    {>= "v0.11.0"}
   "dune"
   "ocaml-compiler-libs"     {>= "v0.11.0"}
-  "ocaml-migrate-parsetree" {>= "1.3.1"}
+  "ocaml-migrate-parsetree" {>= "1.5.0"}
   "ppx_derivers"            {>= "1.0"}
   "stdio"                   {>= "v0.11.0"}
   "ocamlfind"               {with-test}

src/ast_traverse.ml

@@ -30,7 +30,12 @@ class virtual ['res] lift = object
   inherit ['res] Ast.lift
 end
 
+let module_name = function
+  | None -> "_"
+  | Some name -> name
+
 let enter name path = if String.is_empty path then name else path ^ "." ^ name
+let enter_opt name_opt path = enter (module_name name_opt) path
 
 class map_with_path = object
   inherit [string] map_with_context as super
@@ -60,10 +65,10 @@ class map_with_path = object
      isn't, and the "path" constructed here would be able to differentiate
      between them. *)
   method! module_binding path mb =
-       super#module_binding (enter mb.pmb_name.txt path) mb
+    super#module_binding (enter_opt mb.pmb_name.txt path) mb
 
   method! module_declaration path md =
-    super#module_declaration (enter md.pmd_name.txt path) md
+    super#module_declaration (enter_opt md.pmd_name.txt path) md
 
   method! module_type_declaration path mtd =
     super#module_type_declaration (enter mtd.pmtd_name.txt path) mtd
@@ -79,6 +84,9 @@ let var_names_of = object
     | _ -> acc
 end
 
+let ec_enter_module_opt ~loc name_opt ctxt =
+  Expansion_context.Base.enter_module ~loc (module_name name_opt) ctxt
+
 class map_with_expansion_context = object (self)
   inherit [Expansion_context.Base.t] map_with_context as super
 
@@ -87,12 +95,12 @@ class map_with_expansion_context = object (self)
 
   method! module_binding ctxt mb =
     super#module_binding
-      (Expansion_context.Base.enter_module ~loc:mb.pmb_loc mb.pmb_name.txt ctxt)
+      (ec_enter_module_opt ~loc:mb.pmb_loc mb.pmb_name.txt ctxt)
       mb
 
   method! module_declaration ctxt md =
     super#module_declaration
-      (Expansion_context.Base.enter_module ~loc:md.pmd_loc md.pmd_name.txt ctxt)
+      (ec_enter_module_opt ~loc:md.pmd_loc md.pmd_name.txt ctxt)
       md
 
   method! module_type_declaration ctxt mtd =

src/gen/gen_ast_builder.ml

@@ -213,14 +213,18 @@ let generate filename =
   in
   let st =
     [ Str.open_ (Opn.mk (Mod.ident (Loc.lident "Import")))
-    ; Str.module_ (Mb.mk (Loc.mk "M") (Mod.structure (items false)))
-    ; Str.module_ (Mb.mk (Loc.mk "Make")
-                     (Mod.functor_ (Loc.mk "Loc") (Some (Mty.signature [
-                        Sig.value (Val.mk (Loc.mk "loc") (M.ctyp "Location.t"))
-                      ]))
-                        (Mod.structure
-                           (M.stri "let loc = Loc.loc"
-                            :: items true))))
+    ; Str.module_ (Mb.mk (Loc.mk (Some "M")) (Mod.structure (items false)))
+    ; Str.module_ (Mb.mk (Loc.mk (Some "Make"))
+                     (Mod.functor_
+                        (Named
+                           ( (Loc.mk (Some "Loc"))
+                           , (Mty.signature [
+                                Sig.value
+                                  (Val.mk (Loc.mk "loc") (M.ctyp "Location.t"))
+                              ]) ))
+                           (Mod.structure
+                              (M.stri "let loc = Loc.loc"
+                               :: items true))))
     ]
   in
   dump "ast_builder_generated" Pprintast.structure st ~ext:".ml"

src/location_check.ml

@@ -1,4 +1,4 @@
-open! Import
+open Import
 
 module Non_intersecting_ranges : sig
   type t
@@ -93,20 +93,22 @@ let reloc_pmty_functors x =
   let outmost_loc = x.pmty_loc in
   let rec aux x =
     match x.pmty_desc with
-    | Pmty_functor (id, mty_opt, initial_res) ->
+    | Pmty_functor (Unit, initial_res) ->
+      let res = aux initial_res in
+      if phys_equal res initial_res then
+        x
+      else
+        { x with pmty_desc = Pmty_functor (Unit, res) }
+    | Pmty_functor (Named (id, mty), initial_res) ->
       let res = aux initial_res in
       if Location.compare outmost_loc res.pmty_loc = 0 then
-        let loc_start =
-          (match mty_opt with
-          | None -> id.loc
-          | Some mty -> mty.pmty_loc).loc_end
-        in
+        let loc_start = mty.pmty_loc.loc_end in
         let res = { res with pmty_loc = { res.pmty_loc with loc_start } } in
-        { x with pmty_desc = Pmty_functor (id, mty_opt, res) }
+        { x with pmty_desc = Pmty_functor (Named (id, mty), res) }
       else if phys_equal res initial_res then
         x
       else
-        { x with pmty_desc = Pmty_functor (id, mty_opt, res) }
+        { x with pmty_desc = Pmty_functor (Named (id, mty), res) }
     | _ -> x
   in
   aux x
@@ -115,20 +117,22 @@ let reloc_pmod_functors x =
   let outmost_loc = x.pmod_loc in
   let rec aux x =
     match x.pmod_desc with
-    | Pmod_functor (id, mty_opt, initial_res) ->
+    | Pmod_functor (Unit, initial_res) ->
+      let res = aux initial_res in
+      if phys_equal res initial_res then
+        x
+      else
+        { x with pmod_desc = Pmod_functor (Unit, res) }
+    | Pmod_functor (Named (id, mty), initial_res) ->
       let res = aux initial_res in
       if Location.compare outmost_loc res.pmod_loc = 0 then
-        let loc_start =
-          (match mty_opt with
-          | None -> id.loc
-          | Some mty -> mty.pmty_loc).loc_end
-        in
+        let loc_start = mty.pmty_loc.loc_end in
         let res = { res with pmod_loc = { res.pmod_loc with loc_start } } in
-        { x with pmod_desc = Pmod_functor (id, mty_opt, res) }
+        { x with pmod_desc = Pmod_functor (Named (id, mty), res) }
       else if phys_equal res initial_res then
         x
       else
-        { x with pmod_desc = Pmod_functor (id, mty_opt, res) }
+        { x with pmod_desc = Pmod_functor (Named (id, mty), res) }
     | _ -> x
   in
   aux x
@@ -632,7 +636,7 @@ let enforce_invariants fname =
                let acc = self#longident_loc lid acc in
                let acc = self#pattern pat acc in acc) labels acc
       | Ppat_constraint ({ ppat_desc = Ppat_unpack a; _ }, b) ->
-        let acc = self#loc self#string a acc in
+        let acc = self#loc (self#option self#string) a acc in
         self#core_type b acc
       | _ ->
         super#pattern_desc x acc