hphp/hack/src/hhbc/semdiff/semdiff.ml

   1 (**
   2  * Copyright (c) 2017, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the BSD-style license found in the
   6  * LICENSE file in the "hack" directory of this source tree. An additional grant
   7  * of patent rights can be found in the PATENTS file in the same directory.
   8  *
   9 *)
  10 open Hhas_parser
  11 open Diff
  12
  13 module Log = Semdiff_logging
  14
  15 type options = {
  16   files : string * string;
  17 }
  18
  19 let die str =
  20   let oc = stderr in
  21   output_string oc str;
  22   close_out oc;
  23   exit 2
  24
  25 let parse_options () =
  26   let purpose = "Hhas differencing tool" in
  27   let usage =
  28     Printf.sprintf "%s\nUsage: %s file1 file2\n" purpose Sys.argv.(0)
  29   in
  30   let options =
  31     [ ("--verbose"
  32       , Arg.Int (fun i ->
  33                   if i < 0 || 3 < i
  34                   then raise (Arg.Bad "Verbosity level has to be 0, 1, 2, or 3")
  35                   else Log.verbosity_level := i)
  36         (* Change the default logging level in Semdiff_logging.ml *)
  37       , " Set verbosity level 0, 1, 2 or 3 [default: 2]
  38                   0: Displays nothing
  39                   1: Only displays differences on STDOUT
  40                   2: Also displays differences and debugging information on STDOUT
  41                   3: Also displays full trace on STDOUT"
  42       );
  43       ("--laxunset",
  44        Arg.Unit (fun () -> Rhl.lax_unset := true),
  45        " Ignore finalizer ordering effects of Unset instructions"
  46       );
  47       ("--hidesim",
  48        Arg.Unit (fun () -> Log.hide_sim := true),
  49        " hide similarity information"
  50       );
  51       ("--hidesize",
  52        Arg.Unit (fun () -> Log.hide_size := true),
  53        " hide size information"
  54       );
  55       ("--hidedist",
  56        Arg.Unit (fun () -> Log.hide_dist := true),
  57        " hide size information"
  58       );
  59       ("--hideassm",
  60        Arg.Unit (fun () -> Log.hide_assm := true),
  61        " hide assumed & todo information"
  62       );
  63       ("--srcloc",
  64        Arg.Unit (fun () -> Hhas_parser_actions.check_srcloc := true),
  65        " Check line numbers in srcloc directives"
  66       );
  67     ] in
  68   let options = Arg.align ~limit:25 options in
  69   let files = ref [] in
  70   Arg.parse options (fun file -> files := file::!files) usage;
  71   match !files with
  72   | [x; y] ->
  73     (* !files is in reverse order, so swap the files to get the order back *)
  74     { files = (y, x) }
  75   | _ -> die usage
  76
  77 let parse_file program_parser filename =
  78   let channel = open_in filename in (* TODO: error handling *)
  79
  80   let lexer = Lexing.from_channel channel in
  81   let prog =
  82     try program_parser lexer
  83       with Parsing.Parse_error -> (
  84         Printf.eprintf "Parsing of file failed\n";
  85         raise Parsing.Parse_error
  86         )
  87   in
  88   close_in channel;
  89   prog
  90
  91 let run options =
  92   let program_parser = program Hhas_lexer.read in
  93   let prog1 = parse_file program_parser (fst options.files) in
  94   let prog2 = parse_file program_parser (snd options.files) in
  95
  96   let d, (s, e) = program_comparer.comparer prog1 prog2 in
  97   let similarity = (100.0 *. (1.0 -. float_of_int d /. float_of_int (s+1))) in
  98   if not !Log.hide_dist
  99   then
 100     Log.print ~level:0 (Tty.Normal Tty.White) @@ Printf.sprintf "Distance = %.d" d;
 101   if not !Log.hide_sim
 102   then
 103     Log.print ~level:0 (Tty.Normal Tty.White) @@
 104     Printf.sprintf "Similarity = %.2f" similarity;
 105   if not !Log.hide_size
 106   then
 107       Log.print ~level:0 (Tty.Normal Tty.White) @@ Printf.sprintf "Size = %d" s;
 108   if d <> 0
 109   then Log.print ~level:1 (Tty.Normal Tty.White) @@ Printf.sprintf "Edits = \n";
 110   Log.print_edit_sequence ~level:1 e
 111
 112 (* command line driver *)
 113 let _ =
 114   if ! Sys.interactive
 115   then ()
 116   else
 117     (* On windows, setting 'binary mode' avoids to output CRLF on
 118        stdout.  The 'text mode' would not hurt the user in general, but
 119        it breaks the testsuite where the output is compared to the
 120        expected one (i.e. in given file without CRLF). *)
 121     set_binary_mode_out stdout true;
 122     let options = parse_options () in
 123     Unix.handle_unix_error run options