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

Parent Directory | Revision Log

---

Revision 1344 - (view) (download)

1 :	blume	902	(* Copyright 1991 by AT&T Bell Laboratories *)
2 :	macqueen	1344	(* Copyright 2003 by The SML/NJ Fellowship *)
3 :			(* pptype.sml *)
4 :	blume	902
5 :	macqueen	1344	(* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6 :
7 :	blume	902	signature PPTYPE =
8 :			sig
9 :			val typeFormals : int -> string list
10 :			val tyvarPrintname : Types.tyvar -> string
11 :	macqueen	1344	val ppTycon : StaticEnv.staticEnv -> PrettyPrint.stream
12 :	blume	902	-> Types.tycon -> unit
13 :	macqueen	1344	val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.stream
14 :	blume	902	-> Types.tyfun -> unit
15 :	macqueen	1344	val ppType : StaticEnv.staticEnv -> PrettyPrint.stream
16 :	blume	902	-> Types.ty -> unit
17 :			val ppDconDomain : (Types.dtmember vector * Types.tycon list)
18 :			-> StaticEnv.staticEnv
19 :	macqueen	1344	-> PrettyPrint.stream -> Types.ty -> unit
20 :			val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.stream
21 :	blume	902	-> Types.tycon -> unit
22 :			val resetPPType : unit -> unit
23 :	macqueen	1344	val ppFormals : PrettyPrint.stream -> int -> unit
24 :	blume	902
25 :			val debugging : bool ref
26 :			val unalias : bool ref
27 :
28 :			end (* signature PPTYPE *)
29 :
30 :			structure PPType : PPTYPE =
31 :			struct
32 :
33 :			local
34 :			structure SP = SymPath
35 :	macqueen	1336	structure IP = InvPath
36 :	blume	902	structure BT = BasicTypes
37 :			structure T = Types
38 :			structure TU = TypesUtil
39 :			structure PP = PrettyPrint
40 :			open Types PPUtil
41 :			in
42 :
43 :			val debugging = ref false
44 :			val unalias = ref true
45 :
46 :			fun bug s = ErrorMsg.impossible ("PPType: " ^ s)
47 :	macqueen	1344	val pps = PP.string
48 :	blume	902
49 :			fun C f x y = f y x
50 :
51 :			val internals = ElabControl.internals
52 :
53 :	macqueen	1336	val unitPath = IP.extend(IP.empty,Symbol.tycSymbol "unit")
54 :
55 :	blume	902	fun boundTyvarName k =
56 :			let val a = Char.ord #"a"
57 :			in if k < 26
58 :			then String.str(Char.chr(k+a))
59 :			else implode[Char.chr(Int.div(k,26) + a),
60 :			Char.chr(Int.mod(k,26) + a)]
61 :			end
62 :
63 :			fun metaTyvarName' k =
64 :			let val a = Char.ord #"Z" (* use reverse order for meta vars *)
65 :			in if k < 26
66 :			then String.str(Char.chr(a - k))
67 :			else implode[Char.chr(a - (Int.div(k,26))),
68 :			Char.chr(a - (Int.mod(k,26)))]
69 :			end
70 :
71 :			fun typeFormals n =
72 :			let fun loop i =
73 :			if i>=n then []
74 :			else (boundTyvarName i)::loop(i+1)
75 :			in loop 0
76 :			end
77 :
78 :			fun litKindPrintName (lk: T.litKind) =
79 :			case lk
80 :			of T.INT => "int" (* or "INT" *)
81 :			| T.WORD => "word" (* or "WORD" *)
82 :			| T.REAL => "real" (* or "REAL" *)
83 :			| T.CHAR => "char" (* or "CHAR" *)
84 :			| T.STRING => "string" (* or "STRING" *)
85 :
86 :			local (* WARNING -- compiler global variables *)
87 :			val count = ref(~1)
88 :			val metaTyvars = ref([]:tyvar list)
89 :			in
90 :			fun metaTyvarName(tv: tyvar) =
91 :			let fun find([],_) =
92 :			(metaTyvars := tv::(!metaTyvars);
93 :			count := !count+1;
94 :			!count)
95 :			| find(tv'::rest,k) =
96 :			if tv = tv'
97 :			then !count - k
98 :			else find(rest,k+1)
99 :			in metaTyvarName' (find(!metaTyvars,0))
100 :			end
101 :			fun resetPPType() = (count := ~1; metaTyvars := [])
102 :			end
103 :
104 :			fun tvHead (eq,base) =
105 :			(if eq then "''" else "'")^base
106 :
107 :			fun annotate (name,annotation,depthOp) =
108 :			if !internals
109 :			then concat(name::"."::annotation::
110 :			(case depthOp
111 :			of SOME depth => ["[",(Int.toString depth),"]"]
112 :			| NONE => nil))
113 :			else name
114 :
115 :			fun tyvarPrintname (tyvar) = let
116 :			fun prKind info =
117 :			case info of
118 :			INSTANTIATED(VARty(tyvar)) => tyvarPrintname tyvar
119 :			| INSTANTIATED _ => "<INSTANTIATED ?>"
120 :			| OPEN{depth,eq,kind} =>
121 :			tvHead(eq, annotate(metaTyvarName tyvar,
122 :			case kind of META => "M" | FLEX _ => "F",
123 :			SOME depth))
124 :			| UBOUND{name,depth,eq} =>
125 :			tvHead(eq,annotate(Symbol.name name,"U",SOME depth))
126 :			| LITERAL{kind,...} =>
127 :			annotate(litKindPrintName kind,"L",NONE)
128 :			| SCHEME eq =>
129 :			tvHead(eq,annotate(metaTyvarName tyvar,"S",NONE))
130 :			| TV_MARK _ => "<TV_MARK ?>"
131 :			in
132 :			prKind (!tyvar)
133 :			end
134 :
135 :			(*
136 :			fun ppkind ppstrm kind =
137 :			pps ppstrm
138 :			(case kind
139 :			of PRIMITIVE _ => "PRIMITIVE" | FORMAL => "FORMAL"
140 :			| FLEXTYC _ => "FLEXTYC" | ABSTRACT _ => "ABSTYC"
141 :			| DATATYPE _ => "DATATYPE" | TEMP => "TEMP")
142 :			*)
143 :			fun ppkind ppstrm kind =
144 :			pps ppstrm
145 :			(case kind
146 :			of PRIMITIVE _ => "P" | FORMAL => "F"
147 :			| FLEXTYC _ => "X" | ABSTRACT _ => "A"
148 :			| DATATYPE _ => "D" | TEMP => "T")
149 :
150 :			fun effectivePath(path,tyc,env) : string =
151 :			let fun tycPath (GENtyc{path,...} | DEFtyc{path,...} | PATHtyc{path,...}) =
152 :			SOME path
153 :			| tycPath _ = NONE
154 :			fun find(path,tyc) =
155 :			(findPath(path,
156 :			(fn tyc' => TU.equalTycon(tyc',tyc)),
157 :			(fn x => Lookup.lookTyc(env,x,
158 :			(fn _ => raise StaticEnv.Unbound)))))
159 :			fun search(path,tyc) =
160 :			let val (suffix,found) = find(path,tyc)
161 :			in if found then (suffix,true)
162 :			else if not (!unalias) then (suffix, false)
163 :			else case TU.unWrapDef1 tyc
164 :			of SOME tyc' =>
165 :			(case tycPath tyc'
166 :			of SOME path' =>
167 :			let val x as (suffix',found') = search(path',tyc')
168 :			in if found' then x
169 :			else (suffix,false)
170 :			end
171 :			| NONE => (suffix,false))
172 :			| NONE => (suffix,false)
173 :			end
174 :			val (suffix,found) = search(path,tyc)
175 :			val name = SP.toString(SP.SPATH suffix)
176 :			in if found
177 :			then name
178 :			else "?."^name
179 :			end
180 :
181 :			val arrowStamp = BT.arrowStamp
182 :
183 :			fun strength(ty) =
184 :			case ty
185 :			of VARty(ref(INSTANTIATED ty')) => strength(ty')
186 :			| CONty(tycon, args) =>
187 :			(case tycon
188 :			of GENtyc { stamp, kind = PRIMITIVE _, ... } =>
189 :			if Stamps.eq(stamp,arrowStamp) then 0 else 2
190 :			| RECORDtyc (_::_) => (* excepting type unit *)
191 :			if Tuples.isTUPLEtyc(tycon) then 1 else 2
192 :			| _ => 2)
193 :			| _ => 2
194 :
195 :			fun ppEqProp ppstrm p =
196 :			let val a = case p
197 :			of NO => "NO"
198 :			| YES => "YES"
199 :			| IND => "IND"
200 :			| OBJ => "OBJ"
201 :			| DATA => "DATA"
202 :			| ABS => "ABS"
203 :			| UNDEF => "UNDEF"
204 :			in pps ppstrm a
205 :			end
206 :
207 :			fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
208 :	macqueen	1344	PP.string ppstream (SymPath.toString (SymPath.SPATH(rev path)))
209 :	blume	902
210 :			fun ppTycon1 env ppstrm membersOp =
211 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
212 :	blume	902	fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =
213 :			if !internals
214 :	macqueen	1344	then (openHOVBox 1;
215 :	blume	902	ppInvPath ppstrm path;
216 :			pps "[";
217 :			pps "G"; ppkind ppstrm kind; pps ";";
218 :			pps (Stamps.toShortString stamp);
219 :			pps ";";
220 :			ppEqProp ppstrm (!eq);
221 :			pps "]";
222 :	macqueen	1344	closeBox())
223 :	blume	902	else pps(effectivePath(path,tyc,env))
224 :			| ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =
225 :			if !internals
226 :	macqueen	1344	then (openHOVBox 1;
227 :	blume	902	ppInvPath ppstrm path;
228 :			pps "["; pps "D;";
229 :			ppType env ppstrm body;
230 :			pps "]";
231 :	macqueen	1344	closeBox())
232 :	blume	902	else pps(effectivePath(path,tyc,env))
233 :			| ppTyc(RECORDtyc labels) =
234 :			ppClosedSequence ppstrm
235 :	macqueen	1344	{front=C PP.string "{",
236 :			sep=fn ppstrm => (PP.string ppstrm ",";
237 :			PP.break ppstrm {nsp=0,offset=0}),
238 :			back=C PP.string "}",
239 :			style=INCONSISTENT,
240 :	blume	902	pr=ppSym} labels
241 :
242 :			| ppTyc (RECtyc n) =
243 :			(case membersOp
244 :			of SOME (members,_) =>
245 :			let val {tycname,dcons,...} = Vector.sub(members,n)
246 :			in ppSym ppstrm tycname
247 :			end
248 :			| NONE => pps (String.concat ["<RECtyc ",Int.toString n,">"]))
249 :
250 :			| ppTyc (FREEtyc n) =
251 :			(case membersOp
252 :			of SOME (_, freetycs) =>
253 :			let val tyc = (List.nth(freetycs, n) handle _ =>
254 :			bug "unexpected freetycs in ppTyc")
255 :			in ppTyc tyc
256 :			end
257 :			| NONE =>
258 :			pps (String.concat ["<FREEtyc ",Int.toString n,">"]))
259 :
260 :			| ppTyc (tyc as PATHtyc{arity,entPath,path}) =
261 :			if !internals
262 :	macqueen	1344	then (openHOVBox 1;
263 :	blume	902	ppInvPath ppstrm path; pps "[P;";
264 :			pps (EntPath.entPathToString entPath);
265 :			pps "]";
266 :	macqueen	1344	closeBox())
267 :	blume	902	else ppInvPath ppstrm path
268 :
269 :			| ppTyc ERRORtyc = pps "[E]"
270 :			in ppTyc
271 :			end
272 :
273 :
274 :			and ppType1 env ppstrm (ty: ty, sign: T.polysign,
275 :			membersOp: (T.dtmember vector * T.tycon list) option) : unit =
276 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
277 :	blume	902	fun prty ty =
278 :			case ty
279 :			of VARty(ref(INSTANTIATED ty')) => prty(ty')
280 :			| VARty(tv) => ppTyvar tv
281 :			| IBOUND n =>
282 :			let val eq = List.nth(sign,n)
283 :			handle Subscript => false
284 :			in pps (tvHead(eq,(boundTyvarName n)))
285 :			end
286 :			| CONty(tycon, args) => let
287 :			fun otherwise () =
288 :	macqueen	1344	(openHOVBox 2;
289 :	blume	902	ppTypeArgs args;
290 :	macqueen	1344	break{nsp=0,offset=0};
291 :	blume	902	ppTycon1 env ppstrm membersOp tycon;
292 :	macqueen	1344	closeBox())
293 :	blume	902	in
294 :			case tycon
295 :			of GENtyc { stamp, kind, ... } =>
296 :			(case kind of
297 :			PRIMITIVE _ =>
298 :			if Stamps.eq(stamp,arrowStamp)
299 :			then case args
300 :			of [domain,range] =>
301 :	macqueen	1344	(openHVBox 0;
302 :	blume	902	if strength domain = 0
303 :	macqueen	1344	then (openHVBox 1;
304 :	blume	902	pps "(";
305 :			prty domain;
306 :			pps ")";
307 :	macqueen	1344	closeBox())
308 :	blume	902	else prty domain;
309 :	macqueen	1344	break{nsp=1,offset=0};
310 :	blume	902	pps "-> ";
311 :			prty range;
312 :	macqueen	1344	closeBox())
313 :	blume	902	| _ => bug "CONty:arity"
314 :	macqueen	1344	else (openHOVBox 2;
315 :	blume	902	ppTypeArgs args;
316 :	macqueen	1344	break{nsp=0,offset=0};
317 :	blume	902	ppTycon1 env ppstrm membersOp tycon;
318 :	macqueen	1344	closeBox())
319 :	blume	902	| _ => otherwise ())
320 :			| RECORDtyc labels =>
321 :			if Tuples.isTUPLEtyc(tycon)
322 :			then ppTUPLEty args
323 :			else ppRECORDty(labels, args)
324 :			| _ => otherwise ()
325 :			end
326 :			| POLYty{sign,tyfun=TYFUN{arity,body}} =>
327 :			ppType1 env ppstrm (body,sign, membersOp)
328 :			| WILDCARDty => pps "_"
329 :			| UNDEFty => pps "undef"
330 :
331 :			and ppTypeArgs [] = ()
332 :			| ppTypeArgs [ty] =
333 :			(if strength ty <= 1
334 :	macqueen	1344	then (openHOVBox 1;
335 :	blume	902	pps "(";
336 :			prty ty;
337 :			pps ")";
338 :	macqueen	1344	closeBox())
339 :	blume	902	else prty ty;
340 :	macqueen	1344	break{nsp=1,offset=0})
341 :	blume	902	| ppTypeArgs tys =
342 :			ppClosedSequence ppstrm
343 :	macqueen	1344	{front=C PP.string "(",
344 :			sep=fn ppstrm => (PP.string ppstrm ",";
345 :			PP.break ppstrm {nsp=0,offset=0}),
346 :			back=C PP.string ") ",
347 :			style=INCONSISTENT,
348 :	blume	902	pr=fn _ => fn ty => prty ty}
349 :			tys
350 :
351 :	macqueen	1336	and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))
352 :	blume	902	| ppTUPLEty tys =
353 :			ppSequence ppstrm
354 :	macqueen	1344	{sep = fn ppstrm => (PP.break ppstrm {nsp=1,offset=0};
355 :			PP.string ppstrm "* "),
356 :			style = INCONSISTENT,
357 :	blume	902	pr = (fn _ => fn ty =>
358 :			if strength ty <= 1
359 :	macqueen	1344	then (openHOVBox 1;
360 :	blume	902	pps "(";
361 :			prty ty;
362 :			pps ")";
363 :	macqueen	1344	closeBox())
364 :	blume	902	else prty ty)}
365 :			tys
366 :
367 :	macqueen	1344	and ppField(lab,ty) = (openHVBox 0;
368 :	blume	902	ppSym ppstrm lab;
369 :			pps ":";
370 :			prty ty;
371 :	macqueen	1344	closeBox())
372 :	blume	902
373 :	macqueen	1336	and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))
374 :			(* this case should not occur *)
375 :	blume	902	| ppRECORDty(lab::labels, arg::args) =
376 :	macqueen	1344	(openHOVBox 1;
377 :	blume	902	pps "{";
378 :			ppField(lab,arg);
379 :			ListPair.app
380 :	macqueen	1344	(fn field => (pps ","; break{nsp=1,offset=0}; ppField field))
381 :	blume	902	(labels,args);
382 :			pps "}";
383 :	macqueen	1344	closeBox())
384 :	blume	902	| ppRECORDty _ = bug "PPType.ppRECORDty"
385 :
386 :			and ppTyvar (tv as (ref info) :tyvar) :unit =
387 :			let val printname = tyvarPrintname tv
388 :			in case info
389 :			of OPEN{depth,eq,kind} =>
390 :			(case kind
391 :			of FLEX fields =>
392 :			(case fields
393 :			of [] => (pps "{"; pps printname; pps "}")
394 :			| field::fields =>
395 :	macqueen	1344	(openHOVBox 1;
396 :	blume	902	pps "{";
397 :			ppField field;
398 :			app (fn x => (pps ",";
399 :	macqueen	1344	break{nsp=1,offset=0};
400 :	blume	902	ppField x))
401 :			fields;
402 :			pps ";";
403 :	macqueen	1344	break{nsp=1,offset=0};
404 :	blume	902	pps printname;
405 :			pps "}";
406 :	macqueen	1344	closeBox()))
407 :	blume	902	| _ => pps printname)
408 :			| _ => pps printname
409 :			end
410 :			in prty ty
411 :			end (* ppType1 *)
412 :
413 :			and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =
414 :	macqueen	1344	(PP.openHOVBox ppstrm (PP.Rel 1);
415 :	blume	902	ppType1 env ppstrm (ty,[],NONE);
416 :	macqueen	1344	PP.closeBox ppstrm)
417 :	blume	902
418 :			fun ppDconDomain members (env:StaticEnv.staticEnv)
419 :			ppstrm (ty:ty) : unit =
420 :	macqueen	1344	(PP.openHOVBox ppstrm (PP.Rel 1);
421 :	blume	902	ppType1 env ppstrm (ty,[],SOME members);
422 :	macqueen	1344	PP.closeBox ppstrm)
423 :	blume	902
424 :			fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc
425 :
426 :			fun ppTyfun env ppstrm (TYFUN{arity,body}) =
427 :	macqueen	1344	let val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
428 :			in openHOVBox 2;
429 :	blume	902	pps "TYFUN({arity=";
430 :	macqueen	1344	ppi ppstrm arity; ppcomma ppstrm;
431 :			break{nsp=0,offset=0};
432 :	blume	902	pps "body=";
433 :			ppType env ppstrm body;
434 :			pps "})";
435 :	macqueen	1344	closeBox()
436 :	blume	902	end
437 :
438 :			fun ppFormals ppstrm =
439 :			let fun ppF 0 = ()
440 :			| ppF 1 = pps ppstrm " 'a"
441 :			| ppF n = (pps ppstrm " ";
442 :			ppTuple ppstrm (fn ppstrm => fn s => pps ppstrm ("'"^s))
443 :			(typeFormals n))
444 :			in ppF
445 :			end
446 :
447 :			fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =
448 :			let val {index,freetycs,family={members,...},...} = dt
449 :	macqueen	1344	val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
450 :	blume	902	val {dcons,...} = Vector.sub(members,index)
451 :			in
452 :	macqueen	1344	openHVBox 0;
453 :	blume	902	app (fn {name,domain,...} =>
454 :			(pps (Symbol.name name); pps ":";
455 :			case domain
456 :			of SOME ty =>
457 :			ppType1 env ppstrm (ty,[],SOME (members,freetycs))
458 :			| NONE => pps "CONST";
459 :	macqueen	1344	break{nsp=1,offset=0}))
460 :	blume	902	dcons;
461 :	macqueen	1344	closeBox()
462 :	blume	902	end
463 :			| ppDataconTypes env ppstrm _ = bug "ppDataconTypes"
464 :
465 :			end (* toplevel local *)
466 :			end (* structure PPType *)

---

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