hphp/hack/src/hh_single_decl.ml

   1 (*
   2  * Copyright (c) Facebook, Inc. and its affiliates.
   3  *
   4  * This source code is licensed under the MIT license found in the
   5  * LICENSE file in the "hack" directory of this source tree.
   6  *
   7  *)
   8
   9 open Hh_prelude
  10 open Direct_decl_parser
  11
  12 let popt
  13     ~auto_namespace_map
  14     ~enable_xhp_class_modifier
  15     ~disable_xhp_element_mangling
  16     ~enable_enum_classes =
  17   let po = ParserOptions.default in
  18   let po =
  19     ParserOptions.with_disable_xhp_element_mangling
  20       po
  21       disable_xhp_element_mangling
  22   in
  23   let po = ParserOptions.with_auto_namespace_map po auto_namespace_map in
  24   let po =
  25     ParserOptions.with_enable_xhp_class_modifier po enable_xhp_class_modifier
  26   in
  27   let po = ParserOptions.with_enable_enum_classes po enable_enum_classes in
  28   po
  29
  30 let init root popt : Provider_context.t =
  31   Relative_path.(set_path_prefix Root root);
  32   let (_handle : SharedMem.handle) =
  33     SharedMem.init ~num_workers:0 SharedMem.default_config
  34   in
  35   let tcopt =
  36     {
  37       popt with
  38       GlobalOptions.tco_shallow_class_decl = true;
  39       tco_higher_kinded_types = true;
  40     }
  41   in
  42   (* TODO(hverr): Figure out 64-bit *)
  43   let ctx =
  44     Provider_context.empty_for_tool
  45       ~popt
  46       ~tcopt
  47       ~backend:Provider_backend.Shared_memory
  48       ~deps_mode:Typing_deps_mode.SQLiteMode
  49   in
  50
  51   (* Push local stacks here so we don't include shared memory in our timing. *)
  52   File_provider.local_changes_push_sharedmem_stack ();
  53   Decl_provider.local_changes_push_sharedmem_stack ();
  54   Shallow_classes_provider.local_changes_push_sharedmem_stack ();
  55   Linearization_provider.local_changes_push_sharedmem_stack ();
  56
  57   ctx
  58
  59 let rec shallow_declare_ast ctx decls prog =
  60   List.fold prog ~init:decls ~f:(fun decls def ->
  61       let open Aast in
  62       match def with
  63       | Namespace (_, prog) -> shallow_declare_ast ctx decls prog
  64       | NamespaceUse _ -> decls
  65       | SetNamespaceEnv _ -> decls
  66       | FileAttributes _ -> decls
  67       | Fun f ->
  68         let (name, decl) = Decl_nast.fun_naming_and_decl ctx f in
  69         (name, Shallow_decl_defs.Fun decl) :: decls
  70       | Class c ->
  71         let decl = Shallow_classes_provider.decl ctx c in
  72         let (_, name) = decl.Shallow_decl_defs.sc_name in
  73         (name, Shallow_decl_defs.Class decl) :: decls
  74       | RecordDef rd ->
  75         let (name, decl) = Decl_nast.record_def_naming_and_decl ctx rd in
  76         (name, Shallow_decl_defs.Record decl) :: decls
  77       | Typedef typedef ->
  78         let (name, decl) = Decl_nast.typedef_naming_and_decl ctx typedef in
  79         (name, Shallow_decl_defs.Typedef decl) :: decls
  80       | Stmt _ -> decls
  81       | Constant cst ->
  82         let (name, ty) = Decl_nast.const_naming_and_decl ctx cst in
  83         let decl = Typing_defs.{ cd_pos = fst cst.cst_name; cd_type = ty } in
  84         (name, Shallow_decl_defs.Const decl) :: decls)
  85
  86 let compare_decls ctx fn text =
  87   let (ctx, _entry) =
  88     Provider_context.(
  89       add_or_overwrite_entry_contents ~ctx ~path:fn ~contents:text)
  90   in
  91   let ast = Ast_provider.get_ast ctx fn in
  92   let legacy_decls = shallow_declare_ast ctx [] ast in
  93   let legacy_decls_str = show_decls (List.rev legacy_decls) ^ "\n" in
  94   let popt = Provider_context.get_popt ctx in
  95   let auto_namespace_map = ParserOptions.auto_namespace_map popt in
  96   let disable_xhp_element_mangling =
  97     ParserOptions.disable_xhp_element_mangling popt
  98   in
  99   let decls =
 100     parse_decls_ffi disable_xhp_element_mangling fn text auto_namespace_map
 101   in
 102   let decls_str = show_decls (List.rev decls) ^ "\n" in
 103   let matched = String.equal decls_str legacy_decls_str in
 104   if matched then
 105     Printf.eprintf "%s%!" decls_str
 106   else
 107     Tempfile.with_real_tempdir (fun dir ->
 108         let temp_dir = Path.to_string dir in
 109         let expected =
 110           Caml.Filename.temp_file ~temp_dir "expected_decls" ".txt"
 111         in
 112         let actual = Caml.Filename.temp_file ~temp_dir "actual_decls" ".txt" in
 113         Disk.write_file ~file:expected ~contents:legacy_decls_str;
 114         Disk.write_file ~file:actual ~contents:decls_str;
 115         Ppxlib_print_diff.print
 116           ~diff_command:"diff -U9999 --label legacy --label 'direct decl'"
 117           ~file1:expected
 118           ~file2:actual
 119           ());
 120   matched
 121
 122 type modes = CompareDirectDeclParser
 123
 124 let () =
 125   let usage =
 126     Printf.sprintf "Usage: %s [OPTIONS] mode filename\n" Sys.argv.(0)
 127   in
 128   let usage_and_exit () =
 129     prerr_endline usage;
 130     exit 1
 131   in
 132   let mode = ref None in
 133   let set_mode m () =
 134     match !mode with
 135     | None -> mode := Some m
 136     | Some _ -> usage_and_exit ()
 137   in
 138   let file = ref None in
 139   let set_file f =
 140     match !file with
 141     | None -> file := Some f
 142     | Some _ -> usage_and_exit ()
 143   in
 144   let skip_if_errors = ref false in
 145   let expect_extension = ref ".exp" in
 146   let set_expect_extension s = expect_extension := s in
 147   let auto_namespace_map = ref [] in
 148   let enable_xhp_class_modifier = ref false in
 149   let disable_xhp_element_mangling = ref false in
 150   let enable_enum_classes = ref false in
 151   let ignored_flag flag = (flag, Arg.Unit (fun _ -> ()), "(ignored)") in
 152   let ignored_arg flag = (flag, Arg.String (fun _ -> ()), "(ignored)") in
 153   Arg.parse
 154     [
 155       ( "--compare-direct-decl-parser",
 156         Arg.Unit (set_mode CompareDirectDeclParser),
 157         "(mode) Runs the direct decl parser against the FFP -> naming -> decl pipeline and compares their output"
 158       );
 159       ( "--skip-if-errors",
 160         Arg.Set skip_if_errors,
 161         "Skip comparison if the corresponding .exp file has errors" );
 162       ( "--expect-extension",
 163         Arg.String set_expect_extension,
 164         "The extension with which the output of the legacy pipeline should be written"
 165       );
 166       ( "--auto-namespace-map",
 167         Arg.String
 168           (fun m ->
 169             auto_namespace_map := ServerConfig.convert_auto_namespace_to_map m),
 170         "Namespace aliases" );
 171       ( "--enable-xhp-class-modifier",
 172         Arg.Set enable_xhp_class_modifier,
 173         "Enable the XHP class modifier, xhp class name {} will define an xhp class."
 174       );
 175       ( "--disable-xhp-element-mangling",
 176         Arg.Set disable_xhp_element_mangling,
 177         "." );
 178       ( "--enable-enum-classes",
 179         Arg.Set enable_enum_classes,
 180         "Enable the enum classes extension." );
 181       (* The following options do not affect the direct decl parser and can be ignored
 182          (they are used by hh_single_type_check, and we run hh_single_decl over all of
 183          the typecheck test cases). *)
 184       ignored_flag "--abstract-static-props";
 185       ignored_arg "--allowed-decl-fixme-codes";
 186       ignored_arg "--allowed-fixme-codes-strict";
 187       ignored_flag "--allow-toplevel-requires";
 188       ignored_flag "--check-xhp-attribute";
 189       ignored_flag "--complex-coercion";
 190       ignored_flag "--const-attribute";
 191       ignored_flag "--const-static-props";
 192       ignored_flag "--disable-hh-ignore-error";
 193       ignored_flag "--disable-modes";
 194       ignored_flag "--disable-partially-abstract-typeconsts";
 195       ignored_flag "--disable-unset-class-const";
 196       ignored_flag "--disable-xhp-children-declarations";
 197       ignored_flag "--disallow-discarded-nullable-awaitables";
 198       ignored_flag "--disallow-fun-and-cls-meth-pseudo-funcs";
 199       ignored_flag "--disallow-func-ptrs-in-constants";
 200       ignored_flag "--disallow-invalid-arraykey-constraint";
 201       ignored_flag "--disallow-php-lambdas";
 202       ignored_flag "--disallow-silence";
 203       ignored_flag "--disallow-trait-reuse";
 204       ignored_flag "--enable-class-level-where-clauses";
 205       ignored_flag "--enable-higher-kinded-types";
 206       ignored_flag "--enable-systemlib-annotations";
 207       ignored_flag "--forbid_nullable_cast";
 208       ( "--hh-log-level",
 209         Arg.Tuple [Arg.String (fun _ -> ()); Arg.String (fun _ -> ())],
 210         "(ignored)" );
 211       ignored_flag "--like-casts";
 212       ignored_flag "--like-type-hints";
 213       ignored_flag "--like-types-all";
 214       ignored_flag "--method-call-inference";
 215       ignored_flag "--no-builtins";
 216       ignored_flag "--no-strict-contexts";
 217       ignored_flag "--report-pos-from-reason";
 218       ignored_arg "--simple-pessimize";
 219       ignored_arg "--timeout";
 220       ignored_flag "--union-intersection-type-hints";
 221     ]
 222     set_file
 223     usage;
 224   match !mode with
 225   | None -> usage_and_exit ()
 226   | Some CompareDirectDeclParser ->
 227     begin
 228       match !file with
 229       | None -> usage_and_exit ()
 230       | Some file ->
 231         let () =
 232           if
 233             !skip_if_errors
 234             && not
 235                @@ String_utils.is_substring
 236                     "No errors"
 237                     (RealDisk.cat (file ^ ".exp"))
 238           then begin
 239             print_endline "Skipping because input file has errors";
 240             exit 0
 241           end
 242         in
 243         let file = Path.make file in
 244         let auto_namespace_map = !auto_namespace_map in
 245         let enable_xhp_class_modifier = !enable_xhp_class_modifier in
 246         let disable_xhp_element_mangling = !disable_xhp_element_mangling in
 247         let enable_enum_classes = !enable_enum_classes in
 248         let popt =
 249           popt
 250             ~auto_namespace_map
 251             ~enable_xhp_class_modifier
 252             ~disable_xhp_element_mangling
 253             ~enable_enum_classes
 254         in
 255         let ctx = init (Path.dirname file) popt in
 256         let file = Relative_path.(create Root (Path.to_string file)) in
 257         let files = Multifile.file_to_file_list file in
 258         let num_files = List.length files in
 259         let (all_matched, _) =
 260           List.fold
 261             files
 262             ~init:(true, true)
 263             ~f:(fun (matched, is_first) (filename, contents) ->
 264               (* All output is printed to stderr because that's the output
 265                  channel Ppxlib_print_diff prints to. *)
 266               if not is_first then Printf.eprintf "\n%!";
 267               (* Multifile turns the path into an absolute path instead of a
 268                  relative one. Turn it back into a relative path. *)
 269               let filename =
 270                 Relative_path.(create Root (Relative_path.to_absolute filename))
 271               in
 272               if num_files > 1 then
 273                 Printf.eprintf
 274                   "File %s\n%!"
 275                   (Relative_path.storage_to_string filename);
 276               let matched =
 277                 Provider_utils.respect_but_quarantine_unsaved_changes
 278                   ~ctx
 279                   ~f:(fun () -> compare_decls ctx filename contents)
 280                 && matched
 281               in
 282               (matched, false))
 283         in
 284         if all_matched then
 285           Printf.eprintf "\nThey matched!\n%!"
 286         else
 287           exit 1
 288     end