Pprintast prints Jane syntax unconditionally

ocaml/parsing/pprintast.ml

@@ -2066,6 +2066,17 @@ and n_ary_function_expr
           function_params_then_body
             ctxt f params constraint_ body ~delimiter:"->")
 
+(******************************************************************************)
+(* All exported functions must be defined or redefined below here and wrapped in
+   [export_printer] in order to ensure they are invariant with respecto which
+   language extensions are enabled. *)
+
+let Language_extension.For_pprintast.{ print_with_maximal_extensions } =
+  Language_extension.For_pprintast.make_printer_exporter ()
+
+let print_reset_with_maximal_extensions f =
+  print_with_maximal_extensions (f reset_ctxt)
+
 let toplevel_phrase f x =
   match x with
   | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
@@ -2077,19 +2088,25 @@ let toplevel_phrase f x =
   | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
    pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
 
+let toplevel_phrase = print_with_maximal_extensions toplevel_phrase
+
 let expression f x =
   pp f "@[%a@]" (expression reset_ctxt) x
 
+let expression = print_with_maximal_extensions expression
+
 let string_of_expression x =
   ignore (flush_str_formatter ()) ;
   let f = str_formatter in
   expression f x;
   flush_str_formatter ()
 
+let structure = print_reset_with_maximal_extensions structure
+
 let string_of_structure x =
   ignore (flush_str_formatter ());
   let f = str_formatter in
-  structure reset_ctxt f x;
+  structure f x;
   flush_str_formatter ()
 
 let top_phrase f x =
@@ -2098,19 +2115,20 @@ let top_phrase f x =
   pp f ";;";
   pp_print_newline f ()
 
-let core_type = core_type reset_ctxt
-let pattern = pattern reset_ctxt
-let signature = signature reset_ctxt
-let structure = structure reset_ctxt
-let module_expr = module_expr reset_ctxt
-let module_type = module_type reset_ctxt
-let class_field = class_field reset_ctxt
-let class_type_field = class_type_field reset_ctxt
-let class_expr = class_expr reset_ctxt
-let class_type = class_type reset_ctxt
-let class_signature = class_signature reset_ctxt
-let structure_item = structure_item reset_ctxt
-let signature_item = signature_item reset_ctxt
-let binding = binding reset_ctxt
-let payload = payload reset_ctxt
-let type_declaration = type_declaration reset_ctxt
+let longident = print_with_maximal_extensions longident
+let core_type = print_reset_with_maximal_extensions core_type
+let pattern = print_reset_with_maximal_extensions pattern
+let signature = print_reset_with_maximal_extensions signature
+let module_expr = print_reset_with_maximal_extensions module_expr
+let module_type = print_reset_with_maximal_extensions module_type
+let class_field = print_reset_with_maximal_extensions class_field
+let class_type_field = print_reset_with_maximal_extensions class_type_field
+let class_expr = print_reset_with_maximal_extensions class_expr
+let class_type = print_reset_with_maximal_extensions class_type
+let class_signature = print_reset_with_maximal_extensions class_signature
+let structure_item = print_reset_with_maximal_extensions structure_item
+let signature_item = print_reset_with_maximal_extensions signature_item
+let binding = print_reset_with_maximal_extensions binding
+let payload = print_reset_with_maximal_extensions payload
+let type_declaration = print_reset_with_maximal_extensions type_declaration
+

ocaml/testsuite/tests/language-extensions/language_extensions.ml

@@ -1,7 +1,6 @@
 (* TEST
    include ocamlcommon
    flags = "-I ${ocamlsrcdir}/parsing"
-   reference = "${test_source_directory}/reference.txt"
 *)
 
 (* Change these two variables to change which extension is being tested *)

ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml

@@ -0,0 +1,189 @@
+(* TEST
+   include ocamlcommon
+   flags = "-I ${ocamlsrcdir}/parsing"
+*)
+
+(******************************************************************************)
+(* Setup *)
+
+let () = Language_extension.enable_maximal ();;
+
+module Example = struct
+  open Parsetree
+  open Parse
+  open struct
+    let loc = Location.none
+    let located =  Location.mknoloc
+    let parse p str = p (Lexing.from_string str)
+  end
+
+  let longident        = parse longident "No.Longidents.Require.extensions"
+  let expression       = parse expression "[x for x = 1 to 10]"
+  let pattern          = parse pattern "[:_:]"
+  let core_type        = parse core_type "local_ ('a : value) -> unit"
+  let signature        = parse interface "include functor F"
+  let structure        = parse implementation "include functor F"
+  let module_expr      = parse module_expr "struct include functor F end"
+  let toplevel_phrase  = parse toplevel_phrase "#2.17;;"
+  let class_field      = { pcf_desc = Pcf_initializer expression
+                         ; pcf_loc = loc
+                         ; pcf_attributes = []
+                         }
+  let class_type_field = { pctf_desc = Pctf_constraint (core_type, core_type)
+                         ; pctf_loc = loc
+                         ; pctf_attributes = []
+                         }
+  let class_expr       = { pcl_desc =
+                             Pcl_constr (located longident, [core_type])
+                         ; pcl_loc = loc
+                         ; pcl_attributes = []
+                         }
+  let class_type       = { pcty_desc =
+                             Pcty_constr (located longident, [core_type])
+                         ; pcty_loc = loc
+                         ; pcty_attributes = []
+                         }
+  let module_type      = parse module_type "sig include functor F end"
+  let structure_item   = { pstr_desc = Pstr_eval (expression, [])
+                         ; pstr_loc = loc
+                         }
+  let signature_item   = { psig_desc =
+                             Psig_module
+                               { pmd_name = located (Some "M")
+                               ; pmd_type = module_type
+                               ; pmd_attributes = []
+                               ; pmd_loc = loc
+                               }
+                         ; psig_loc = loc
+                         }
+  let value_binding    = { pvb_pat = pattern
+                         ; pvb_expr = expression
+                         ; pvb_attributes = []
+                         ; pvb_loc = loc
+                         }
+  let payload          = PStr structure
+  let class_signature  = { pcsig_self = core_type
+                         ; pcsig_fields = [ class_type_field ]
+                         }
+  let type_declaration = { ptype_name = located "t"
+                         ; ptype_params = []
+                         ; ptype_cstrs = []
+                         ; ptype_kind = Ptype_abstract
+                         ; ptype_private = Public
+                         ; ptype_manifest = Some core_type
+                         ; ptype_attributes = []
+                         ; ptype_loc = loc
+                         }
+end
+
+let print_test_header name =
+  Format.printf "##### %s@;%s@." name (String.make 32 '-')
+;;
+
+let print_test_separator () =
+  Format.printf "@.%s@.@."
+    (String.init 75 (fun i -> if i mod 2 = 0 then '*' else ' '))
+;;
+
+module type Test = sig
+  val name : string
+  val setup : unit -> unit
+end
+
+module Print_all (Test : Test) () : sig
+  (* Ensure that we test every export of [Pprintast] *)
+  include module type of Pprintast
+end = struct
+  open Pprintast
+  type nonrec space_formatter = space_formatter
+
+  let print_test_case name printer wrap_value value =
+    let pp f x =
+      try printer f (wrap_value x)
+      with Jane_syntax_parsing.Error.Error _ ->
+        Format.fprintf f "JANE SYNTAX ERROR FROM PPRINTAST"
+    in
+    Format.printf "@.@[<2>%s:@;%a@]@." name pp value
+  ;;
+
+  let test name pp value =
+    print_test_case name pp Fun.id value;
+    pp
+  ;;
+
+  let test_string_of name string_of value =
+    print_test_case name Format.pp_print_string string_of value;
+    string_of
+  ;;
+
+  let () =
+    print_test_header Test.name;
+    Test.setup ()
+  ;;
+
+  let longident = test "longident" longident Example.longident
+  let expression = test "expression" expression Example.expression
+  let pattern = test "pattern" pattern Example.pattern
+  let core_type = test "core_type" core_type Example.core_type
+  let signature = test "signature" signature Example.signature
+  let structure = test "structure" structure Example.structure
+  let module_expr = test "module_expr" module_expr Example.module_expr
+  let toplevel_phrase = test "toplevel_phrase" toplevel_phrase Example.toplevel_phrase
+  let top_phrase = test "top_phrase" top_phrase Example.toplevel_phrase
+  let class_field = test "class_field" class_field Example.class_field
+  let class_type_field = test "class_type_field" class_type_field Example.class_type_field
+  let class_expr = test "class_expr" class_expr Example.class_expr
+  let class_type = test "class_type" class_type Example.class_type
+  let module_type = test "module_type" module_type Example.module_type
+  let structure_item = test "structure_item" structure_item Example.structure_item
+  let signature_item = test "signature_item" signature_item Example.signature_item
+  let binding = test "binding" binding Example.value_binding
+  let payload = test "payload" payload Example.payload
+  let class_signature = test "class_signature" class_signature Example.class_signature
+  let type_declaration = test "type_declaration" type_declaration Example.type_declaration
+
+  let string_of_expression = test_string_of "string_of_expression" string_of_expression Example.expression
+  let string_of_structure = test_string_of "string_of_structure" string_of_structure Example.structure
+end
+
+
+(******************************************************************************)
+(* Tests *)
+
+(* [Pprintast] can correctly print when the extension is enabled. *)
+module _ =
+  Print_all
+    (struct
+      let name = "All extensions enabled"
+      let setup () = Language_extension.enable_maximal ()
+    end)
+    ()
+;;
+
+let () = print_test_separator ();;
+
+(* [Pprintast] can correctly print when the extension is disabled. *)
+module _ =
+  Print_all
+    (struct
+      let name = "Extensions disallowed"
+      let setup () = Language_extension.disallow_extensions ()
+    end)
+    ()
+;;
+
+let () = print_test_separator ();;
+
+(* Can't call [Language_extension.For_pprintast.make_printer_exporter]. *)
+let () =
+  print_test_header
+    "Calling [Language_extension.For_pprintast.make_printer_exporter ()]";
+  Format.print_newline ();
+  begin match Language_extension.For_pprintast.make_printer_exporter () with
+  | _ ->
+    Format.printf "INCORRECT SUCCESS"
+  | exception Misc.Fatal_error ->
+    Format.printf "Correctly raised a fatal error"
+  end;
+  Format.print_newline ()
+;;

ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference

@@ -0,0 +1,115 @@
+##### All extensions enabled
+--------------------------------
+
+longident: No.Longidents.Require.extensions
+
+expression: [x for x = 1 to 10]
+
+pattern: [:_:]
+
+core_type: local_ ('a : value) -> unit
+
+signature: include functor F
+
+structure: include functor F
+
+module_expr: struct include functor F end
+
+toplevel_phrase: ;;#2.17
+
+top_phrase: 
+;;#2.17;;
+
+
+class_field: initializer [x for x = 1 to 10]
+
+class_type_field:
+  constraint local_ ('a : value) -> unit = local_ ('a : value) -> unit
+
+class_expr: [local_ ('a : value) -> unit] No.Longidents.Require.extensions
+
+class_type: [local_ ('a : value) -> unit] No.Longidents.Require.extensions
+
+module_type: sig include functor F end
+
+structure_item: ;;[x for x = 1 to 10]
+
+signature_item: module M : sig include functor F end
+
+binding: [:_:] = [x for x = 1 to 10]
+
+payload: include functor F
+
+class_signature:
+  object (local_ ('a : value) -> unit)
+    constraint local_ ('a : value) -> unit = local_ ('a : value) -> unit
+  end
+
+type_declaration:  local_ ('a : value) -> unit
+
+string_of_expression: [x for x = 1 to 10]
+
+string_of_structure: include functor F
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+##### Extensions disallowed
+--------------------------------
+
+longident: No.Longidents.Require.extensions
+
+expression: [x for x = 1 to 10]
+
+pattern: [:_:]
+
+core_type: local_ ('a : value) -> unit
+
+signature: include functor F
+
+structure: include functor F
+
+module_expr: struct include functor F end
+
+toplevel_phrase: ;;#2.17
+
+top_phrase: 
+;;#2.17;;
+
+
+class_field: initializer [x for x = 1 to 10]
+
+class_type_field:
+  constraint local_ ('a : value) -> unit = local_ ('a : value) -> unit
+
+class_expr: [local_ ('a : value) -> unit] No.Longidents.Require.extensions
+
+class_type: [local_ ('a : value) -> unit] No.Longidents.Require.extensions
+
+module_type: sig include functor F end
+
+structure_item: ;;[x for x = 1 to 10]
+
+signature_item: module M : sig include functor F end
+
+binding: [:_:] = [x for x = 1 to 10]
+
+payload: include functor F
+
+class_signature:
+  object (local_ ('a : value) -> unit)
+    constraint local_ ('a : value) -> unit = local_ ('a : value) -> unit
+  end
+
+type_declaration:  local_ ('a : value) -> unit
+
+string_of_expression: [x for x = 1 to 10]
+
+string_of_structure: include functor F
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+##### Calling [Language_extension.For_pprintast.make_printer_exporter ()]
+--------------------------------
+
+>> Fatal error: Only Pprintast may use [Language_extension.For_pprintast]
+Correctly raised a fatal error