|
| 1 | +(* TEST |
| 2 | + include ocamlcommon |
| 3 | + flags = "-I ${ocamlsrcdir}/parsing" |
| 4 | +*) |
| 5 | + |
| 6 | +(******************************************************************************) |
| 7 | +(* Setup *) |
| 8 | + |
| 9 | +let () = Language_extension.enable_maximal ();; |
| 10 | + |
| 11 | +module Example = struct |
| 12 | + open Parsetree |
| 13 | + open Parse |
| 14 | + open struct |
| 15 | + let loc = Location.none |
| 16 | + let located = Location.mknoloc |
| 17 | + let parse p str = p (Lexing.from_string str) |
| 18 | + end |
| 19 | + |
| 20 | + let longident = parse longident "No.Longidents.Require.extensions" |
| 21 | + let expression = parse expression "[x for x = 1 to 10]" |
| 22 | + let pattern = parse pattern "[:_:]" |
| 23 | + let core_type = parse core_type "local_ ('a : value) -> unit" |
| 24 | + let signature = parse interface "include functor F" |
| 25 | + let structure = parse implementation "include functor F" |
| 26 | + let module_expr = parse module_expr "struct include functor F end" |
| 27 | + let toplevel_phrase = parse toplevel_phrase "#2.17;;" |
| 28 | + let class_field = { pcf_desc = Pcf_initializer expression |
| 29 | + ; pcf_loc = loc |
| 30 | + ; pcf_attributes = [] |
| 31 | + } |
| 32 | + let class_type_field = { pctf_desc = Pctf_constraint (core_type, core_type) |
| 33 | + ; pctf_loc = loc |
| 34 | + ; pctf_attributes = [] |
| 35 | + } |
| 36 | + let class_expr = { pcl_desc = |
| 37 | + Pcl_constr (located longident, [core_type]) |
| 38 | + ; pcl_loc = loc |
| 39 | + ; pcl_attributes = [] |
| 40 | + } |
| 41 | + let class_type = { pcty_desc = |
| 42 | + Pcty_constr (located longident, [core_type]) |
| 43 | + ; pcty_loc = loc |
| 44 | + ; pcty_attributes = [] |
| 45 | + } |
| 46 | + let module_type = parse module_type "sig include functor F end" |
| 47 | + let structure_item = { pstr_desc = Pstr_eval (expression, []) |
| 48 | + ; pstr_loc = loc |
| 49 | + } |
| 50 | + let signature_item = { psig_desc = |
| 51 | + Psig_module |
| 52 | + { pmd_name = located (Some "M") |
| 53 | + ; pmd_type = module_type |
| 54 | + ; pmd_attributes = [] |
| 55 | + ; pmd_loc = loc |
| 56 | + } |
| 57 | + ; psig_loc = loc |
| 58 | + } |
| 59 | + let value_binding = { pvb_pat = pattern |
| 60 | + ; pvb_expr = expression |
| 61 | + ; pvb_attributes = [] |
| 62 | + ; pvb_loc = loc |
| 63 | + } |
| 64 | + let payload = PStr structure |
| 65 | + let class_signature = { pcsig_self = core_type |
| 66 | + ; pcsig_fields = [ class_type_field ] |
| 67 | + } |
| 68 | + let type_declaration = { ptype_name = located "t" |
| 69 | + ; ptype_params = [] |
| 70 | + ; ptype_cstrs = [] |
| 71 | + ; ptype_kind = Ptype_abstract |
| 72 | + ; ptype_private = Public |
| 73 | + ; ptype_manifest = Some core_type |
| 74 | + ; ptype_attributes = [] |
| 75 | + ; ptype_loc = loc |
| 76 | + } |
| 77 | +end |
| 78 | + |
| 79 | +let print_test_header name = |
| 80 | + Format.printf "##### %s@;%s@." name (String.make 32 '-') |
| 81 | +;; |
| 82 | + |
| 83 | +let print_test_separator () = |
| 84 | + Format.printf "@.%s@.@." |
| 85 | + (String.init 75 (fun i -> if i mod 2 = 0 then '*' else ' ')) |
| 86 | +;; |
| 87 | + |
| 88 | +module type Test = sig |
| 89 | + val name : string |
| 90 | + val setup : unit -> unit |
| 91 | +end |
| 92 | + |
| 93 | +module Print_all (Test : Test) () : sig |
| 94 | + (* Ensure that we test every export of [Pprintast] *) |
| 95 | + include module type of Pprintast |
| 96 | +end = struct |
| 97 | + open Pprintast |
| 98 | + type nonrec space_formatter = space_formatter |
| 99 | + |
| 100 | + let print_test_case name printer wrap_value value = |
| 101 | + let pp f x = |
| 102 | + try printer f (wrap_value x) |
| 103 | + with Jane_syntax_parsing.Error.Error _ -> |
| 104 | + Format.fprintf f "JANE SYNTAX ERROR FROM PPRINTAST" |
| 105 | + in |
| 106 | + Format.printf "@.@[<2>%s:@;%a@]@." name pp value |
| 107 | + ;; |
| 108 | + |
| 109 | + let test name pp value = |
| 110 | + print_test_case name pp Fun.id value; |
| 111 | + pp |
| 112 | + ;; |
| 113 | + |
| 114 | + let test_string_of name string_of value = |
| 115 | + print_test_case name Format.pp_print_string string_of value; |
| 116 | + string_of |
| 117 | + ;; |
| 118 | + |
| 119 | + let () = |
| 120 | + print_test_header Test.name; |
| 121 | + Test.setup () |
| 122 | + ;; |
| 123 | + |
| 124 | + let longident = test "longident" longident Example.longident |
| 125 | + let expression = test "expression" expression Example.expression |
| 126 | + let pattern = test "pattern" pattern Example.pattern |
| 127 | + let core_type = test "core_type" core_type Example.core_type |
| 128 | + let signature = test "signature" signature Example.signature |
| 129 | + let structure = test "structure" structure Example.structure |
| 130 | + let module_expr = test "module_expr" module_expr Example.module_expr |
| 131 | + let toplevel_phrase = test "toplevel_phrase" toplevel_phrase Example.toplevel_phrase |
| 132 | + let top_phrase = test "top_phrase" top_phrase Example.toplevel_phrase |
| 133 | + let class_field = test "class_field" class_field Example.class_field |
| 134 | + let class_type_field = test "class_type_field" class_type_field Example.class_type_field |
| 135 | + let class_expr = test "class_expr" class_expr Example.class_expr |
| 136 | + let class_type = test "class_type" class_type Example.class_type |
| 137 | + let module_type = test "module_type" module_type Example.module_type |
| 138 | + let structure_item = test "structure_item" structure_item Example.structure_item |
| 139 | + let signature_item = test "signature_item" signature_item Example.signature_item |
| 140 | + let binding = test "binding" binding Example.value_binding |
| 141 | + let payload = test "payload" payload Example.payload |
| 142 | + let class_signature = test "class_signature" class_signature Example.class_signature |
| 143 | + let type_declaration = test "type_declaration" type_declaration Example.type_declaration |
| 144 | + |
| 145 | + let string_of_expression = test_string_of "string_of_expression" string_of_expression Example.expression |
| 146 | + let string_of_structure = test_string_of "string_of_structure" string_of_structure Example.structure |
| 147 | +end |
| 148 | + |
| 149 | + |
| 150 | +(******************************************************************************) |
| 151 | +(* Tests *) |
| 152 | + |
| 153 | +(* [Pprintast] can correctly print when the extension is enabled. *) |
| 154 | +module _ = |
| 155 | + Print_all |
| 156 | + (struct |
| 157 | + let name = "All extensions enabled" |
| 158 | + let setup () = Language_extension.enable_maximal () |
| 159 | + end) |
| 160 | + () |
| 161 | +;; |
| 162 | + |
| 163 | +let () = print_test_separator ();; |
| 164 | + |
| 165 | +(* [Pprintast] can correctly print when the extension is disabled. *) |
| 166 | +module _ = |
| 167 | + Print_all |
| 168 | + (struct |
| 169 | + let name = "Extensions disallowed" |
| 170 | + let setup () = Language_extension.disallow_extensions () |
| 171 | + end) |
| 172 | + () |
| 173 | +;; |
| 174 | + |
| 175 | +let () = print_test_separator ();; |
| 176 | + |
| 177 | +(* Can't call [Language_extension.For_pprintast.make_printer_exporter]. *) |
| 178 | +let () = |
| 179 | + print_test_header |
| 180 | + "Calling [Language_extension.For_pprintast.make_printer_exporter ()]"; |
| 181 | + Format.print_newline (); |
| 182 | + begin match Language_extension.For_pprintast.make_printer_exporter () with |
| 183 | + | _ -> |
| 184 | + Format.printf "INCORRECT SUCCESS" |
| 185 | + | exception Misc.Fatal_error -> |
| 186 | + Format.printf "Correctly raised a fatal error" |
| 187 | + end; |
| 188 | + Format.print_newline () |
| 189 | +;; |
0 commit comments