viewcvs.cgi/ocamliface/mltypes.ml

exception Error of string

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
    ["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit" ]

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
       | Tvar ->  failwith "Polymorphic value"
       | 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
                          | [] -> Abstract pn
                          | _ -> failwith ("Polymorphic abstract type: " ^ pn))))
       | _ -> failwith "Unsupported feature"
    );
    slot

let unfold = unfold IntMap.empty StringMap.empty

(* Reading .cmi *)

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

let read_cmi name =
  Config.load_path := Config.standard_library :: !Librarian.obj_path;
  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}) -> 
           values := (Ident.name id, t, unfold t) :: !values
       | Tsig_type (id,t) -> 
           Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
       | 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"
    ) sg;
  (Buffer.contents buf, !values)

let print_ocaml = Printtyp.type_expr


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
1	exception Error of string
2
3	open OCaml_all
4	open Asttypes
5	open Types
6
7	(* Unfolding of OCaml types *)
8
9	let ocaml_env = ref Env.initial
10
11	type t = { uid : int; mutable recurs : int; mutable def : def }
12	and def =
13	\| Link of t
14	\| Arrow of t * t
15	\| Tuple of t list
16	\| PVariant of (string * t option) list (* Polymorphic variant *)
17	\| Variant of (string * t list) list * bool
18	\| Record of (string * t) list * bool
19	\| Builtin of string * t list
20	\| Abstract of string
21
22	module IntMap =
23	Map.Make(struct type t = int let compare : t -> t -> int = compare end)
24	module StringMap =
25	Map.Make(struct type t = string let compare : t -> t -> int = compare end)
26
27	let rec print_sep f sep ppf = function
28	\| [] -> ()
29	\| [x] -> f ppf x
30	\| x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
31
32	let printed = ref IntMap.empty
33
34	let rec print_slot ppf slot =
35	if slot.recurs > 0 then
36	(
37	if IntMap.mem slot.uid !printed then
38	Format.fprintf ppf "X%i" slot.uid
39	else (
40	printed := IntMap.add slot.uid () !printed;
41	Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
42	)
43	)
44	else
45	print_def ppf slot.def
46
47	and print_def ppf = function
48	\| Link t -> print_slot ppf t
49	\| Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s
50	\| Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
51	\| PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " \| ") l
52	\| Variant (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " \| ") l
53	\| Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l
54	\| Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
55	\| Abstract s -> Format.fprintf ppf "%s" s
56
57
58	and print_palt ppf = function
59	\| lab, None -> Format.fprintf ppf "`%s" lab
60	\| lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
61
62	and print_alt ppf = function
63	\| (lab,[]) ->
64	Format.fprintf ppf "%s" lab
65	\| (lab,l) ->
66	Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l
67
68	and print_field ppf (lab,t) =
69	Format.fprintf ppf "%s:%a" lab print_slot t
70
71
72	let print = print_slot
73
74	let counter = ref 0
75	let new_slot () =
76	incr counter;
77	{ uid = !counter; recurs = 0; def = Abstract "DUMMY" }
78
79	let builtins =
80	List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
81	["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit" ]
82
83	let rec unfold seen constrs ty =
84	try
85	let t = IntMap.find ty.id seen in
86	t.recurs <- t.recurs + 1;
87	t
88	with Not_found ->
89	let slot = new_slot () in
90	let seen = IntMap.add ty.id slot seen in
91	let loop = unfold seen constrs in
92	slot.def <-
93	(match ty.desc with
94	\| Tarrow (_,t1,t2,_) -> Arrow (loop t1, loop t2)
95	\| Ttuple tyl -> Tuple (List.map loop tyl)
96	\| Tvariant rd ->
97	let fields =
98	List.map
99	(fun (lab,f) ->
100	match f with
101	\| Rpresent (Some t) -> (lab, Some (loop t))
102	\| Rpresent None -> (lab, None)
103	\| _ -> assert false)
104	rd.row_fields in
105	PVariant fields
106	\| Tvar -> failwith "Polymorphic value"
107	\| Tconstr (p,args,_) ->
108	let args = List.map loop args in
109	let pn = Path.name p in
110	if StringMap.mem pn builtins
111	then Builtin (pn,args)
112	else
113	let decl =
114	try Env.find_type p !ocaml_env
115	with Not_found ->
116	failwith ("Cannot resolve path " ^ pn) in
117	(try
118	let (s,args') = StringMap.find pn constrs in
119	List.iter2
120	(fun a a' ->
121	if a.uid != a'.uid then
122	failwith "Polymorphic recursion forbidden") args args';
123	s.recurs <- s.recurs + 1;
124	Link s
125	with Not_found ->
126	let seen =
127	List.fold_left2
128	(fun seen a v -> a.recurs <- a.recurs - 1; IntMap.add v.id a seen)
129	seen args decl.type_params in
130	let constrs = StringMap.add pn (slot,args) constrs in
131	let loop = unfold seen constrs in
132	(match decl.type_kind, decl.type_manifest with
133	\| Type_variant (cstrs,pub), _ ->
134	let cstrs =
135	List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in
136	Variant (cstrs, pub = Public)
137	\| Type_record (f,_,pub), _ ->
138	let f = List.map (fun (l,_,t) -> (l,loop t)) f in
139	Record (f, pub = Public)
140	\| Type_abstract, Some t ->
141	Link (loop t)
142	\| Type_abstract, None ->
143	(match args with
144	\| [] -> Abstract pn
145	\| _ -> failwith ("Polymorphic abstract type: " ^ pn))))
146	\| _ -> failwith "Unsupported feature"
147	);
148	slot
149
150	let unfold = unfold IntMap.empty StringMap.empty
151
152	(* Reading .cmi *)
153
154	let unsupported s =
155	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	let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
160	let sg = Env.read_signature name filename in
161	ocaml_env := Env.add_signature sg Env.initial;
162	let buf = Buffer.create 1024 in
163	let ppf = Format.formatter_of_buffer buf in
164	let values = ref [] in
165	List.iter
166	(function
167	\| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
168	values := (Ident.name id, t, unfold t) :: !values
169	\| Tsig_type (id,t) ->
170	Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
171	\| Tsig_value (_,_) -> unsupported "external value"
172	\| Tsig_exception (_,_) -> unsupported "exception"
173	\| Tsig_module (_,_) -> unsupported "module"
174	\| Tsig_modtype (_,_) -> unsupported "module type"
175	\| Tsig_class (_,_) -> unsupported "class"
176	\| Tsig_cltype (_,_) -> unsupported "class type"
177	) sg;
178	(Buffer.contents buf, !values)
179
180	let print_ocaml = Printtyp.type_expr
181
182
183	let rec dump_li = function
184	\| Longident.Lident s -> print_endline s
185	\| Longident.Ldot (li,s) -> dump_li li; print_endline s
186	\| _ -> assert false
187
188	let find_value v =
189	Config.load_path := Config.standard_library :: !Librarian.obj_path;
190	let li = Longident.parse v in
191	let (p,vd) = Env.lookup_value li Env.initial in
192	unfold vd.val_type