Diff of /sml/trunk/src/compiler/Elaborator/print/pptype.sml

Parent Directory | Revision Log | Patch

	revision 1343, Wed Aug 13 17:44:22 2003 UTC	revision 1344, Wed Aug 13 18:04:08 2003 UTC
#	Line 1	Line 1
1	(* Copyright 1991 by AT&T Bell Laboratories *)	(* Copyright 1991 by AT&T Bell Laboratories *)
2		(* Copyright 2003 by The SML/NJ Fellowship *)
3		(* pptype.sml *)
4
5		(* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6
7	signature PPTYPE =	signature PPTYPE =
8	sig	sig
9	val typeFormals : int -> string list	val typeFormals : int -> string list
10	val tyvarPrintname : Types.tyvar -> string	val tyvarPrintname : Types.tyvar -> string
11	val ppTycon : StaticEnv.staticEnv -> PrettyPrint.ppstream	val ppTycon : StaticEnv.staticEnv -> PrettyPrint.stream
12	-> Types.tycon -> unit	-> Types.tycon -> unit
13	val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.ppstream	val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.stream
14	-> Types.tyfun -> unit	-> Types.tyfun -> unit
15	val ppType  : StaticEnv.staticEnv -> PrettyPrint.ppstream	val ppType  : StaticEnv.staticEnv -> PrettyPrint.stream
16	-> Types.ty -> unit	-> Types.ty -> unit
17	val ppDconDomain : (Types.dtmember vector * Types.tycon list)	val ppDconDomain : (Types.dtmember vector * Types.tycon list)
18	-> StaticEnv.staticEnv	-> StaticEnv.staticEnv
19	-> PrettyPrint.ppstream -> Types.ty -> unit	-> PrettyPrint.stream -> Types.ty -> unit
20	val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.ppstream	val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.stream
21	-> Types.tycon -> unit	-> Types.tycon -> unit
22	val resetPPType : unit -> unit	val resetPPType : unit -> unit
23	val ppFormals : PrettyPrint.ppstream -> int -> unit	val ppFormals : PrettyPrint.stream -> int -> unit
24
25	val debugging : bool ref	val debugging : bool ref
26	val unalias : bool ref	val unalias : bool ref
#	Line 40	Line 44
44	val unalias = ref true	val unalias = ref true
45
46	fun bug s = ErrorMsg.impossible ("PPType: " ^ s)	fun bug s = ErrorMsg.impossible ("PPType: " ^ s)
47	val pps = PP.add_string	val pps = PP.string
48
49	fun C f x y = f y x	fun C f x y = f y x
50
#	Line 201	Line 205
205	end	end
206
207	fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =	fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
208	PP.add_string ppstream (SymPath.toString (SymPath.SPATH(rev path)))	PP.string ppstream (SymPath.toString (SymPath.SPATH(rev path)))
209
210	fun ppTycon1 env ppstrm membersOp =	fun ppTycon1 env ppstrm membersOp =
211	let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm	let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
212	fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =	fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =
213	if !internals	if !internals
214	then (begin_block PP.INCONSISTENT 1;	then (openHOVBox 1;
215	ppInvPath ppstrm path;	ppInvPath ppstrm path;
216	pps "[";	pps "[";
217	pps "G"; ppkind ppstrm kind; pps ";";	pps "G"; ppkind ppstrm kind; pps ";";
#	Line 215	Line 219
219	pps ";";	pps ";";
220	ppEqProp ppstrm (!eq);	ppEqProp ppstrm (!eq);
221	pps "]";	pps "]";
222	end_block())	closeBox())
223	else pps(effectivePath(path,tyc,env))	else pps(effectivePath(path,tyc,env))
224	| ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =	| ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =
225	if !internals	if !internals
226	then (begin_block PP.INCONSISTENT 1;	then (openHOVBox 1;
227	ppInvPath ppstrm path;	ppInvPath ppstrm path;
228	pps "["; pps "D;";	pps "["; pps "D;";
229	ppType env ppstrm body;	ppType env ppstrm body;
230	pps "]";	pps "]";
231	end_block())	closeBox())
232	else pps(effectivePath(path,tyc,env))	else pps(effectivePath(path,tyc,env))
233	| ppTyc(RECORDtyc labels) =	| ppTyc(RECORDtyc labels) =
234	ppClosedSequence ppstrm	ppClosedSequence ppstrm
235	{front=C PP.add_string "{",	{front=C PP.string "{",
236	sep=fn ppstrm => (PP.add_string ppstrm ",";	sep=fn ppstrm => (PP.string ppstrm ",";
237	PP.add_break ppstrm (0,0)),	PP.break ppstrm {nsp=0,offset=0}),
238	back=C PP.add_string "}",	back=C PP.string "}",
239	style=PP.INCONSISTENT,	style=INCONSISTENT,
240	pr=ppSym} labels	pr=ppSym} labels
241
242	| ppTyc (RECtyc n) =	| ppTyc (RECtyc n) =
#	Line 255	Line 259
259
260	| ppTyc (tyc as PATHtyc{arity,entPath,path}) =	| ppTyc (tyc as PATHtyc{arity,entPath,path}) =
261	if !internals	if !internals
262	then (begin_block PP.INCONSISTENT 1;	then (openHOVBox 1;
263	ppInvPath ppstrm path; pps "[P;";	ppInvPath ppstrm path; pps "[P;";
264	pps (EntPath.entPathToString entPath);	pps (EntPath.entPathToString entPath);
265	pps "]";	pps "]";
266	end_block())	closeBox())
267	else ppInvPath ppstrm path	else ppInvPath ppstrm path
268
269	| ppTyc ERRORtyc = pps "[E]"	| ppTyc ERRORtyc = pps "[E]"
#	Line 269	Line 273
273
274	and ppType1 env ppstrm (ty: ty, sign: T.polysign,	and ppType1 env ppstrm (ty: ty, sign: T.polysign,
275	membersOp: (T.dtmember vector * T.tycon list) option) : unit =	membersOp: (T.dtmember vector * T.tycon list) option) : unit =
276	let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm	let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
277	fun prty ty =	fun prty ty =
278	case ty	case ty
279	of VARty(ref(INSTANTIATED ty')) => prty(ty')	of VARty(ref(INSTANTIATED ty')) => prty(ty')
#	Line 281	Line 285
285	end	end
286	| CONty(tycon, args) => let	| CONty(tycon, args) => let
287	fun otherwise () =	fun otherwise () =
288	(begin_block PP.INCONSISTENT 2;	(openHOVBox 2;
289	ppTypeArgs args;	ppTypeArgs args;
290	add_break(0,0);	break{nsp=0,offset=0};
291	ppTycon1 env ppstrm membersOp tycon;	ppTycon1 env ppstrm membersOp tycon;
292	end_block())	closeBox())
293	in	in
294	case tycon	case tycon
295	of GENtyc { stamp, kind, ... } =>	of GENtyc { stamp, kind, ... } =>
#	Line 294	Line 298
298	if Stamps.eq(stamp,arrowStamp)	if Stamps.eq(stamp,arrowStamp)
299	then case args	then case args
300	of [domain,range] =>	of [domain,range] =>
301	(begin_block PP.CONSISTENT 0;	(openHVBox 0;
302	if strength domain = 0	if strength domain = 0
303	then (begin_block PP.CONSISTENT 1;	then (openHVBox 1;
304	pps "(";	pps "(";
305	prty domain;	prty domain;
306	pps ")";	pps ")";
307	end_block())	closeBox())
308	else prty domain;	else prty domain;
309	add_break(1,0);	break{nsp=1,offset=0};
310	pps "-> ";	pps "-> ";
311	prty range;	prty range;
312	end_block())	closeBox())
313	| _ => bug "CONty:arity"	| _ => bug "CONty:arity"
314	else (begin_block PP.INCONSISTENT 2;	else (openHOVBox 2;
315	ppTypeArgs args;	ppTypeArgs args;
316	add_break(0,0);	break{nsp=0,offset=0};
317	ppTycon1 env ppstrm membersOp tycon;	ppTycon1 env ppstrm membersOp tycon;
318	end_block())	closeBox())
319	| _ => otherwise ())	| _ => otherwise ())
320	| RECORDtyc labels =>	| RECORDtyc labels =>
321	if Tuples.isTUPLEtyc(tycon)	if Tuples.isTUPLEtyc(tycon)
#	Line 327	Line 331
331	and ppTypeArgs [] = ()	and ppTypeArgs [] = ()
332	| ppTypeArgs [ty] =	| ppTypeArgs [ty] =
333	(if strength ty <= 1	(if strength ty <= 1
334	then (begin_block PP.INCONSISTENT 1;	then (openHOVBox 1;
335	pps "(";	pps "(";
336	prty ty;	prty ty;
337	pps ")";	pps ")";
338	end_block())	closeBox())
339	else prty ty;	else prty ty;
340	add_break(1,0))	break{nsp=1,offset=0})
341	| ppTypeArgs tys =	| ppTypeArgs tys =
342	ppClosedSequence ppstrm	ppClosedSequence ppstrm
343	{front=C PP.add_string "(",	{front=C PP.string "(",
344	sep=fn ppstrm => (PP.add_string ppstrm ",";	sep=fn ppstrm => (PP.string ppstrm ",";
345	PP.add_break ppstrm (0,0)),	PP.break ppstrm {nsp=0,offset=0}),
346	back=C PP.add_string ") ",	back=C PP.string ") ",
347	style=PP.INCONSISTENT,	style=INCONSISTENT,
348	pr=fn _ => fn ty => prty ty}	pr=fn _ => fn ty => prty ty}
349	tys	tys
350
351	and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))	and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))
352	| ppTUPLEty tys =	| ppTUPLEty tys =
353	ppSequence ppstrm	ppSequence ppstrm
354	{sep = fn ppstrm => (PP.add_break ppstrm (1,0);	{sep = fn ppstrm => (PP.break ppstrm {nsp=1,offset=0};
355	PP.add_string ppstrm "* "),	PP.string ppstrm "* "),
356	style = PP.INCONSISTENT,	style = INCONSISTENT,
357	pr = (fn _ => fn ty =>	pr = (fn _ => fn ty =>
358	if strength ty <= 1	if strength ty <= 1
359	then (begin_block PP.INCONSISTENT 1;	then (openHOVBox 1;
360	pps "(";	pps "(";
361	prty ty;	prty ty;
362	pps ")";	pps ")";
363	end_block())	closeBox())
364	else prty ty)}	else prty ty)}
365	tys	tys
366
367	and ppField(lab,ty) = (begin_block PP.CONSISTENT 0;	and ppField(lab,ty) = (openHVBox 0;
368	ppSym ppstrm lab;	ppSym ppstrm lab;
369	pps ":";	pps ":";
370	prty ty;	prty ty;
371	end_block())	closeBox())
372
373	and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))	and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))
374	(* this case should not occur *)	(* this case should not occur *)
375	| ppRECORDty(lab::labels, arg::args) =	| ppRECORDty(lab::labels, arg::args) =
376	(begin_block PP.INCONSISTENT 1;	(openHOVBox 1;
377	pps "{";	pps "{";
378	ppField(lab,arg);	ppField(lab,arg);
379	ListPair.app	ListPair.app
380	(fn field => (pps ","; add_break(1,0);ppField field))	(fn field => (pps ","; break{nsp=1,offset=0}; ppField field))
381	(labels,args);	(labels,args);
382	pps "}";	pps "}";
383	end_block())	closeBox())
384	| ppRECORDty _ = bug "PPType.ppRECORDty"	| ppRECORDty _ = bug "PPType.ppRECORDty"
385
386	and ppTyvar (tv as (ref info) :tyvar) :unit =	and ppTyvar (tv as (ref info) :tyvar) :unit =
#	Line 388	Line 392
392	(case fields	(case fields
393	of [] => (pps "{"; pps printname; pps "}")	of [] => (pps "{"; pps printname; pps "}")
394	| field::fields =>	| field::fields =>
395	(begin_block PP.INCONSISTENT 1;	(openHOVBox 1;
396	pps "{";	pps "{";
397	ppField field;	ppField field;
398	app (fn x => (pps ",";	app (fn x => (pps ",";
399	add_break(1,0);	break{nsp=1,offset=0};
400	ppField x))	ppField x))
401	fields;	fields;
402	pps ";";	pps ";";
403	add_break(1,0);	break{nsp=1,offset=0};
404	pps printname;	pps printname;
405	pps "}";	pps "}";
406	end_block()))	closeBox()))
407	| _ => pps printname)	| _ => pps printname)
408	| _ => pps printname	| _ => pps printname
409	end	end
#	Line 407	Line 411
411	end  (* ppType1 *)	end  (* ppType1 *)
412
413	and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =	and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =
414	(PP.begin_block ppstrm PP.INCONSISTENT 1;	(PP.openHOVBox ppstrm (PP.Rel 1);
415	ppType1 env ppstrm (ty,[],NONE);	ppType1 env ppstrm (ty,[],NONE);
416	PP.end_block ppstrm)	PP.closeBox ppstrm)
417
418	fun ppDconDomain members (env:StaticEnv.staticEnv)	fun ppDconDomain members (env:StaticEnv.staticEnv)
419	ppstrm (ty:ty) : unit =	ppstrm (ty:ty) : unit =
420	(PP.begin_block ppstrm PP.INCONSISTENT 1;	(PP.openHOVBox ppstrm (PP.Rel 1);
421	ppType1 env ppstrm (ty,[],SOME members);	ppType1 env ppstrm (ty,[],SOME members);
422	PP.end_block ppstrm)	PP.closeBox ppstrm)
423
424	fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc	fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc
425
426	fun ppTyfun env ppstrm (TYFUN{arity,body}) =	fun ppTyfun env ppstrm (TYFUN{arity,body}) =
427	let val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm	let val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
428	in begin_block PP.INCONSISTENT 2;	in openHOVBox 2;
429	pps "TYFUN({arity=";	pps "TYFUN({arity=";
430	ppi ppstrm arity; add_comma ppstrm;	ppi ppstrm arity; ppcomma ppstrm;
431	add_break(0,0);	break{nsp=0,offset=0};
432	pps "body=";	pps "body=";
433	ppType env ppstrm body;	ppType env ppstrm body;
434	pps "})";	pps "})";
435	end_block()	closeBox()
436	end	end
437
438	fun ppFormals ppstrm =	fun ppFormals ppstrm =
#	Line 442	Line 446
446
447	fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =	fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =
448	let val {index,freetycs,family={members,...},...} = dt	let val {index,freetycs,family={members,...},...} = dt
449	val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm	val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
450	val {dcons,...} = Vector.sub(members,index)	val {dcons,...} = Vector.sub(members,index)
451	in	in
452	begin_block PP.CONSISTENT 0;	openHVBox 0;
453	app (fn {name,domain,...} =>	app (fn {name,domain,...} =>
454	(pps (Symbol.name name); pps ":";	(pps (Symbol.name name); pps ":";
455	case domain	case domain
456	of SOME ty =>	of SOME ty =>
457	ppType1 env ppstrm (ty,[],SOME (members,freetycs))	ppType1 env ppstrm (ty,[],SOME (members,freetycs))
458	| NONE => pps "CONST";	| NONE => pps "CONST";
459	add_break(1,0)))	break{nsp=1,offset=0}))
460	dcons;	dcons;
461	end_block()	closeBox()
462	end	end
463	| ppDataconTypes env ppstrm _ = bug "ppDataconTypes"	| ppDataconTypes env ppstrm _ = bug "ppDataconTypes"
464

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.1343   changed lines   Added in v.1344

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0