typing/stypes.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2003 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Recording and dumping (partial) type information *)
  16
  17 (*
  18   We record all types in a list as they are created.
  19   This means we can dump type information even if type inference fails,
  20   which is extremely important, since type information is most
  21   interesting in case of errors.
  22 *)
  23
  24 open Format;;
  25 open Lexing;;
  26 open Location;;
  27 open Typedtree;;
  28
  29 type type_info =
  30     Ti_pat   of pattern
  31   | Ti_expr  of expression
  32   | Ti_class of class_expr
  33   | Ti_mod   of module_expr
  34 ;;
  35
  36 let get_location ti =
  37   match ti with
  38     Ti_pat p   -> p.pat_loc
  39   | Ti_expr e  -> e.exp_loc
  40   | Ti_class c -> c.cl_loc
  41   | Ti_mod m   -> m.mod_loc
  42 ;;
  43
  44 let type_info = ref ([] : type_info list);;
  45 let phrases = ref ([] : Location.t list);;
  46
  47 let record ti =
  48   if !Clflags.save_types && not (get_location ti).Location.loc_ghost then
  49     type_info := ti :: !type_info
  50 ;;
  51
  52 let record_phrase loc =
  53   if !Clflags.save_types then phrases := loc :: !phrases;
  54 ;;
  55
  56 (* comparison order:
  57    the intervals are sorted by order of increasing upper bound
  58    same upper bound -> sorted by decreasing lower bound
  59 *)
  60 let cmp_loc_inner_first loc1 loc2 =
  61   match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
  62   | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
  63   | x -> x
  64 ;;
  65 let cmp_ti_inner_first ti1 ti2 =
  66   cmp_loc_inner_first (get_location ti1) (get_location ti2)
  67 ;;
  68
  69 let print_position pp pos =
  70   fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum;
  71 ;;
  72
  73 let sort_filter_phrases () =
  74   let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in
  75   let rec loop accu cur l =
  76     match l with
  77     | [] -> accu
  78     | loc :: t ->
  79        if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum
  80           && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum
  81        then loop accu cur t
  82        else loop (loc :: accu) loc t
  83   in
  84   phrases := loop [] Location.none ph;
  85 ;;
  86
  87 let rec printtyp_reset_maybe loc =
  88   match !phrases with
  89   | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum ->
  90      Printtyp.reset ();
  91      phrases := t;
  92      printtyp_reset_maybe loc;
  93   | _ -> ()
  94 ;;
  95
  96
  97 (* The format of the annotation file is documented in emacs/caml-types.el. *)
  98
  99 let print_info pp ti =
 100   match ti with
 101   | Ti_class _ | Ti_mod _ -> ()
 102   | Ti_pat  {pat_loc = loc; pat_type = typ}
 103   | Ti_expr {exp_loc = loc; exp_type = typ} ->
 104       print_position pp loc.loc_start;
 105       fprintf pp " ";
 106       print_position pp loc.loc_end;
 107       fprintf pp "@.type(@.  ";
 108       printtyp_reset_maybe loc;
 109       Printtyp.mark_loops typ;
 110       Printtyp.type_sch pp typ;
 111       fprintf pp "@.)@.";
 112 ;;
 113
 114 let get_info () =
 115   let info = List.fast_sort cmp_ti_inner_first !type_info in
 116   type_info := [];
 117   info
 118 ;;
 119
 120 let dump filename =
 121   if !Clflags.save_types then begin
 122     let info = get_info () in
 123     let pp = formatter_of_out_channel (open_out filename) in
 124     sort_filter_phrases ();
 125     List.iter (print_info pp) info;
 126     phrases := [];
 127   end else begin
 128     type_info := [];
 129   end;
 130 ;;