mltypes.ml 5.82 KB
Newer Older
1
exception Error of string
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

open OCaml_all
open Asttypes
open Types

(* Unfolding of OCaml types *)

let ocaml_env = ref Env.initial

type t = { uid : int; mutable recurs : int; mutable def : def }
and def =
  | Link of t
  | Arrow of t * t
  | Tuple of t list
  | PVariant of (string * t option) list  (* Polymorphic variant *)
  | Variant of (string * t list) list * bool
  | Record of (string * t) list * bool
  | Builtin of string * t list
  | Abstract of string

module IntMap = 
  Map.Make(struct type t = int let compare : t -> t -> int = compare end)
module StringMap = 
  Map.Make(struct type t = string let compare : t -> t -> int = compare end)

let rec print_sep f sep ppf = function
  | [] -> ()
  | [x] -> f ppf x
  | x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl

let printed = ref IntMap.empty

let rec print_slot ppf slot =
  if slot.recurs > 0 then
    (
      if IntMap.mem slot.uid !printed then
	Format.fprintf ppf "X%i" slot.uid
      else (
	printed := IntMap.add slot.uid () !printed;
	Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
      )
    )
  else 
    print_def ppf slot.def

and print_def ppf = function
  | Link t -> print_slot ppf t
  | Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s
  | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
  | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
  | Variant (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " | ") l
  | Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l
  | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
  | Abstract s -> Format.fprintf ppf "%s" s


and print_palt ppf = function
  | lab, None -> Format.fprintf ppf "`%s" lab
  | lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
   
and print_alt ppf = function
  | (lab,[]) ->
      Format.fprintf ppf "%s" lab
  | (lab,l) ->
      Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l

and print_field ppf (lab,t) =
  Format.fprintf ppf "%s:%a" lab print_slot t


let print = print_slot

let counter = ref 0
let new_slot () =
  incr counter;
  { uid = !counter; recurs = 0; def = Abstract "DUMMY" }

let builtins =
  List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
81
    ["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit" ]
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

let rec unfold seen constrs ty =
  try
    let t = IntMap.find ty.id seen in
    t.recurs <- t.recurs + 1;
    t
  with Not_found ->
    let slot = new_slot () in
    let seen = IntMap.add ty.id slot seen in
    let loop = unfold seen constrs in
    slot.def <-
    (match ty.desc with
       | Tarrow (_,t1,t2,_) -> Arrow (loop t1, loop t2)
       | Ttuple tyl -> Tuple (List.map loop tyl)
       | Tvariant rd ->
	   let fields = 
	     List.map
	       (fun (lab,f) -> 
		  match f with
		    | Rpresent (Some t) -> (lab, Some (loop t))
		    | Rpresent None -> (lab, None)
		    | _ -> assert false)
	       rd.row_fields in
	   PVariant fields
106
       | Tvar ->  failwith "Polymorphic value"
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
       | Tconstr (p,args,_) ->
	   let args = List.map loop args in
	   let pn = Path.name p in
	   if StringMap.mem pn builtins 
	   then Builtin (pn,args)
	   else
	     let decl = 
	       try Env.find_type p !ocaml_env
	       with Not_found ->
		 failwith ("Cannot resolve path " ^ pn) in
	     (try
		let (s,args') = StringMap.find pn constrs in
		List.iter2 
		  (fun a a' -> 
		     if a.uid != a'.uid then 
		       failwith "Polymorphic recursion forbidden") args args';
		s.recurs <- s.recurs + 1;
		Link s
	      with Not_found ->
		let seen = 
		  List.fold_left2 
		    (fun seen a v -> a.recurs <- a.recurs - 1; IntMap.add v.id a seen)
		    seen args decl.type_params in
		let constrs = StringMap.add pn (slot,args) constrs in
		let loop = unfold seen constrs in
		(match decl.type_kind, decl.type_manifest with
		   | Type_variant (cstrs,pub), _ ->
		       let cstrs =
			 List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in
		       Variant (cstrs, pub = Public)
		   | Type_record (f,_,pub), _ ->
		       let f = List.map (fun (l,_,t) -> (l,loop t)) f in
		       Record (f, pub = Public)
		   | Type_abstract, Some t ->
		       Link (loop t)
		   | Type_abstract, None ->
		       (match args with
144
145
			  | [] -> Abstract pn
			  | _ -> failwith ("Polymorphic abstract type: " ^ pn))))
146
147
148
149
150
151
152
153
       | _ -> failwith "Unsupported feature"
    );
    slot

let unfold = unfold IntMap.empty StringMap.empty

(* Reading .cmi *)

154
155
let unsupported s =
  raise (Error (Printf.sprintf "Unsupport feature (%s) found in .cmi" s))
156
157

let read_cmi name =
158
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
159
160
161
162
163
164
165
166
167
  let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
  let sg = Env.read_signature name filename in
  ocaml_env := Env.add_signature sg Env.initial;
  let buf = Buffer.create 1024 in
  let ppf = Format.formatter_of_buffer buf in
  let values = ref [] in
  List.iter
    (function
       | Tsig_value (id, {val_type=t;val_kind=Val_reg}) -> 
168
	   values := (Ident.name id, t, unfold t) :: !values
169
170
       | Tsig_type (id,t) -> 
	   Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
171
172
173
174
175
176
       | Tsig_value (_,_) -> unsupported "external value"
       | Tsig_exception (_,_) -> unsupported "exception"
       | Tsig_module (_,_) -> unsupported "module"
       | Tsig_modtype (_,_) -> unsupported "module type"
       | Tsig_class (_,_) -> unsupported "class"
       | Tsig_cltype (_,_) -> unsupported "class type"
177
178
179
    ) sg;
  (Buffer.contents buf, !values)

180
let print_ocaml = Printtyp.type_expr
181
182
183
184
185
186
187
188
189
190
191
192


let rec dump_li = function
  | Longident.Lident s -> print_endline s
  | Longident.Ldot (li,s) -> dump_li li; print_endline s
  | _ -> assert false

let find_value v =
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
  let li = Longident.parse v in
  let (p,vd) = Env.lookup_value li Env.initial in
  unfold vd.val_type