mltypes.ml 8.37 KB
Newer Older
1
exception Error of string
2

3
module Loc = Location
4
open Caml_cduce
5
6
7
8
9
open Asttypes
open Types

(* Unfolding of OCaml types *)

10
11
exception PolyAbstract of string

12
13
14
15
16
let ocaml_env = ref Env.initial

type t = { uid : int; mutable recurs : int; mutable def : def }
and def =
  | Link of t
17
  | Arrow of string * t * t
18
19
  | Tuple of t list
  | PVariant of (string * t option) list  (* Polymorphic variant *)
20
21
  | Variant of string * (string * t list) list * bool
  | Record of string * (string * t) list * bool
22
23
  | Builtin of string * t list
  | Abstract of string
24
  | Var of int
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

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
53
  | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
54
55
  | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
  | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
56
57
  | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
  | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
58
59
  | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
  | Abstract s -> Format.fprintf ppf "%s" s
60
  | Var i -> Format.fprintf ppf "'a%i" i
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85


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
86
87
88
    [
      "list"; "Pervasives.ref"; 
      "unit"; "array";
89
      "Big_int.big_int";
90
      "option";
91
92
      "Cduce_lib.Value.t"; "Cduce_lib.Encodings.Utf8.t"
    ]
93

94
95
96
97
98
99
100
101
102
let vars = ref []

let get_var id =
  try List.assq id !vars
  with Not_found ->
    let i = List.length !vars in
    vars := (id,i) :: !vars;
    i

103
104
105
106
107
108
109
110
111
112
113
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
114
       | Tarrow (l,t1,t2,_) -> let t1 = loop t1 in let t2 = loop t2 in Arrow (l, t1,t2)
115
116
117
       | Ttuple tyl -> Tuple (List.map loop tyl)
       | Tvariant rd ->
	   let fields = 
118
119
	     List.fold_left
	       (fun accu (lab,f) -> 
120
		  match f with
121
122
123
124
125
126
127
		    | Rpresent (Some t) 
		    | Reither(true, [t], _, _) -> (lab, Some (loop t)) :: accu
		    | Rpresent None 
		    | Reither(true, [], _, _) -> (lab, None) :: accu
		    | Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
		    | Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
	       ) []
128
129
	       rd.row_fields in
	   PVariant fields
130
       | Tvar -> Var (get_var ty.id)
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
       | 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
156
157
158
159
		let prefix = match p with
		  | Path.Pident _ -> ""
		  | Path.Pdot (p,_,_) -> Path.name p ^ "."
		  | _ -> assert false in
160
161
162
163
		(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
164
		       Variant (prefix, cstrs, pub = Public)
165
166
		   | Type_record (f,_,pub), _ ->
		       let f = List.map (fun (l,_,t) -> (l,loop t)) f in
167
		       Record (prefix, f, pub = Public)
168
169
170
171
		   | Type_abstract, Some t ->
		       Link (loop t)
		   | Type_abstract, None ->
		       (match args with
172
			  | [] -> Abstract pn
173
			  | _ -> raise (PolyAbstract pn))))
174
175
176
177
       | _ -> failwith "Unsupported feature"
    );
    slot

178
179
180
181
182
183
let unfold ty = 
  vars := [];
  let t = unfold IntMap.empty StringMap.empty ty in
  let n = List.length !vars in
  vars := [];
  (t,n)
184
185
186

(* Reading .cmi *)

187
188
let unsupported s =
  raise (Error (Printf.sprintf "Unsupport feature (%s) found in .cmi" s))
189

190
191
192
193
194
let has_cmi name =
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
  try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
  with Not_found -> false

195
196
197
198
let find_value v =
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
  let li = Longident.parse v in
  ocaml_env := Env.initial;
199
  let (_,vd) = Env.lookup_value li Env.initial in
200
201
  unfold vd.val_type

202
let values_of_sig name sg =
203
204
205
  List.fold_left
    (fun accu v -> match v with
       | Tsig_value (id,_) -> 
206
207
208
209
210
211
212
	   let id = Ident.name id in
	   (match id.[0] with
	     | 'a'..'z' | '_' ->
		 let n = name ^ "." ^ id in
		 (try (n, (fst (find_value n))) :: accu
		  with PolyAbstract _ -> accu)
	     | _ -> accu (* operator *))
213
214
       | _ -> accu
    ) [] sg
215

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234

let load_module name = 
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
  let li = Longident.parse name in
  ocaml_env := Env.initial;
  let (_,mty) = Env.lookup_module li Env.initial in
  match mty with
    | Tmty_signature sg -> values_of_sig name sg
    | _ -> raise (Loc.Generic 
		    (Printf.sprintf "Module %s is not a structure" name))

(*
  let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
  let sg = Env.read_signature name filename in
  values_of_sig sg
*)

let load_module name =
  try load_module name
235
236
237
238
239
  with Env.Error e ->
    Env.report_error Format.str_formatter e;
    let s = Format.flush_str_formatter () in
    let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
	      name s in
240
    raise (Loc.Generic s)
241

242
let read_cmi name =
243
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
244
245
246
247
248
249
250
251
252
  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}) -> 
253
254
255
	   let (unf,n) = unfold t in
	   if n !=0 then unsupported "polymorphic value";
	   values := (Ident.name id, t, unf) :: !values
256
257
258
       | Tsig_type (id,t,rs) -> 
	   Format.fprintf ppf "%a@."
	     !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
259
260
261
262
263
264
       | 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"
265
266
267
    ) sg;
  (Buffer.contents buf, !values)

268
269
270
271
272
273
274
let read_cmi name =
  try read_cmi name
  with Env.Error e ->
    Env.report_error Format.str_formatter e;
    let s = Format.flush_str_formatter () in
    let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
	      name s in
275
    raise (Loc.Generic s)
276
277


278
let print_ocaml = Printtyp.type_expr
279
280
281
282
283
284
285


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