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

Parent Directory | Revision Log

---

Revision 1344 - (view) (download)

1 :	blume	902	(* Copyright 1996 by AT&T Bell Laboratories *)
2 :	macqueen	1344	(* Copyright 2003 by The SML/NJ Fellowship *)
3 :	blume	902	(* ppmod.sml *)
4 :
5 :	macqueen	1344	(* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6 :
7 :	blume	902	signature PPMOD =
8 :			sig
9 :	macqueen	1344	val ppSignature: PrettyPrint.stream
10 :	blume	902	-> Modules.Signature * StaticEnv.staticEnv * int -> unit
11 :	macqueen	1344	val ppStructure: PrettyPrint.stream
12 :	blume	902	-> Modules.Structure * StaticEnv.staticEnv * int -> unit
13 :	macqueen	1344	val ppOpen: PrettyPrint.stream
14 :	blume	902	-> SymPath.path * Modules.Structure * StaticEnv.staticEnv * int -> unit
15 :	macqueen	1344	val ppStructureName : PrettyPrint.stream
16 :	blume	902	-> Modules.Structure * StaticEnv.staticEnv -> unit
17 :	macqueen	1344	val ppFunctor : PrettyPrint.stream
18 :	blume	902	-> Modules.Functor * StaticEnv.staticEnv * int -> unit
19 :	macqueen	1344	val ppFunsig : PrettyPrint.stream
20 :	blume	902	-> Modules.fctSig * StaticEnv.staticEnv * int -> unit
21 :	macqueen	1344	val ppBinding: PrettyPrint.stream
22 :	blume	902	-> Symbol.symbol * Bindings.binding * StaticEnv.staticEnv * int
23 :			-> unit
24 :	macqueen	1344	val ppEnv : PrettyPrint.stream
25 :	blume	902	-> StaticEnv.staticEnv * StaticEnv.staticEnv * int *
26 :			Symbol.symbol list option
27 :			-> unit
28 :
29 :			(* module internals *)
30 :
31 :			val ppElements : (StaticEnv.staticEnv * int * Modules.entityEnv option)
32 :	macqueen	1344	-> PrettyPrint.stream
33 :	blume	902	-> Modules.elements -> unit
34 :
35 :	macqueen	1344	val ppEntity : PrettyPrint.stream
36 :	blume	902	-> Modules.entity * StaticEnv.staticEnv * int
37 :			-> unit
38 :
39 :	macqueen	1344	val ppEntityEnv : PrettyPrint.stream
40 :	blume	902	-> Modules.entityEnv * StaticEnv.staticEnv * int
41 :			-> unit
42 :
43 :			end (* signature PPMOD *)
44 :
45 :
46 :			structure PPModules : PPMOD =
47 :			struct
48 :
49 :			local structure S = Symbol
50 :			structure SP = SymPath
51 :			structure IP = InvPath
52 :			structure A = Access
53 :			(* structure II = InlInfo *)
54 :			structure T = Types
55 :			structure TU = TypesUtil
56 :			structure BT = BasicTypes
57 :			structure V = VarCon
58 :			structure M = Modules
59 :			structure MU = ModuleUtil
60 :			structure B = Bindings
61 :			structure SE = StaticEnv
62 :			structure EE = EntityEnv
63 :			structure LU = Lookup
64 :
65 :			structure PP = PrettyPrint
66 :			open PrettyPrint PPUtil
67 :
68 :			in
69 :
70 :			val internals = ElabControl.internals
71 :			fun bug msg = ErrorMsg.impossible("PPModules: "^msg)
72 :			fun C f x y = f y x;
73 :
74 :	macqueen	1344	val pps = PP.string
75 :	blume	902	val ppType = PPType.ppType
76 :			val ppTycon = PPType.ppTycon
77 :			val ppTyfun = PPType.ppTyfun
78 :			val ppFormals = PPType.ppFormals
79 :
80 :			val resultId = S.strSymbol "<resultStr>"
81 :
82 :			fun strToEnv(M.SIG {elements,...},entities) =
83 :			let fun bindElem ((sym,spec), env) =
84 :			case spec
85 :			of M.TYCspec{entVar,...} =>
86 :			let val tyc = EE.lookTycEnt(entities,entVar)
87 :			in SE.bind(sym,B.TYCbind tyc,env)
88 :			end
89 :			| M.STRspec{entVar,sign,...} =>
90 :			let val strEnt = EE.lookStrEnt(entities,entVar)
91 :			in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,
92 :			access=A.nullAcc,
93 :			info=II.Null}),
94 :			env)
95 :			end
96 :			| M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
97 :			| _ => env
98 :			in foldl bindElem SE.empty elements
99 :			end
100 :			| strToEnv _ = SE.empty
101 :
102 :			fun sigToEnv(M.SIG {elements,...}) =
103 :			let fun bindElem ((sym,spec), env) =
104 :			(case spec
105 :			of M.TYCspec{spec,...} => SE.bind(sym,B.TYCbind spec,env)
106 :			| M.STRspec{sign,slot,def,entVar=ev} =>
107 :			SE.bind(sym,B.STRbind(M.STRSIG{sign=sign,entPath=[ev]}),env)
108 :			| M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
109 :			| _ => env)
110 :			in foldl bindElem SE.empty elements
111 :			end
112 :			| sigToEnv _ = bug "sigToEnv"
113 :
114 :			(*
115 :			* Support for a hack to make sure that non-visible ConBindings don't
116 :			* cause spurious blank lines when pp-ing signatures.
117 :			*)
118 :			fun is_ppable_ConBinding (T.DATACON{rep=A.EXN _, ...}, _) = true
119 :			| is_ppable_ConBinding (con,env) =
120 :			let exception Hidden
121 :			val visibleDconTyc =
122 :			let val tyc = TU.dconTyc con
123 :			in (TU.equalTycon
124 :			(LU.lookTyc
125 :			(env,
126 :			SP.SPATH[IP.last(TU.tycPath tyc)],
127 :			fn _ => raise Hidden),
128 :			tyc)
129 :			handle Hidden => false)
130 :			end
131 :			in (!internals orelse not visibleDconTyc)
132 :			end
133 :
134 :			fun all_ppable_bindings alist env =
135 :			List.filter (fn (name,B.CONbind con) => is_ppable_ConBinding(con,env)
136 :			| b => true)
137 :			alist
138 :
139 :
140 :	macqueen	1344	fun ppLty ppstrm ( (* lambdaty,depth *) ) = pps ppstrm "<lambdaty>"
141 :	blume	902
142 :			fun ppEntVar ppstrm entVar =
143 :	macqueen	1344	pps ppstrm (EntPath.entVarToString entVar)
144 :	blume	902
145 :			fun ppEntPath ppstrm entPath =
146 :	macqueen	1344	pps ppstrm (EntPath.entPathToString entPath)
147 :	blume	902	(* ppClosedSequence ppstream
148 :	macqueen	1344	{front=(fn ppstrm => pps ppstrm "["),
149 :			sep=(fn ppstrm => (pps ppstrm ","; break ppstrm {nsp=0,offset=0})),
150 :			back=(fn ppstrm => pps ppstrm "]"),
151 :	blume	902	style=INCONSISTENT,
152 :			pr=ppEntVar}
153 :			*)
154 :
155 :			fun ppTycExp ppstrm (tycExp,depth) =
156 :	macqueen	1344	if depth <= 0 then pps ppstrm "<tycExp>" else
157 :	blume	902	case tycExp
158 :			of M.VARtyc ep =>
159 :	macqueen	1344	(pps ppstrm "TE.V:"; break ppstrm {nsp=1,offset=1};
160 :	blume	902	ppEntPath ppstrm ep)
161 :			| M.CONSTtyc tycon =>
162 :	macqueen	1344	(pps ppstrm "TE.C:"; break ppstrm {nsp=1,offset=1};
163 :	blume	902	ppTycon SE.empty ppstrm tycon)
164 :			| M.FORMtyc tycon =>
165 :	macqueen	1344	(pps ppstrm "TE.FM:"; break ppstrm {nsp=1,offset=1};
166 :	blume	902	ppTycon SE.empty ppstrm tycon)
167 :
168 :			fun ppStructureName ppstrm (str,env) =
169 :			let val rpath =
170 :			case str
171 :			of M.STR { rlzn, ... } => #rpath rlzn
172 :			| _ => bug "ppStructureName"
173 :			fun look a = LU.lookStr(env,a,(fn _ => raise StaticEnv.Unbound))
174 :			fun check str' = MU.eqOrigin(str',str)
175 :			val (syms,found) = findPath(rpath,check,look)
176 :			in pps ppstrm (if found then SP.toString(SP.SPATH syms)
177 :			else "?"^(SP.toString(SP.SPATH syms)))
178 :			end
179 :
180 :			fun ppVariable ppstrm =
181 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
182 :	blume	902	fun ppV(V.VALvar{path,access,typ,info},env:StaticEnv.staticEnv) =
183 :	macqueen	1344	(openHVBox 0;
184 :			pps (SP.toString path);
185 :	blume	902	if !internals then PPVal.ppAccess ppstrm access else ();
186 :			pps " : "; ppType env ppstrm (!typ);
187 :	macqueen	1344	closeBox())
188 :	blume	902	| ppV (V.OVLDvar {name,options=ref optl,scheme=T.TYFUN{body,...}},env) =
189 :	macqueen	1344	(openHVBox 0;
190 :	blume	902	ppSym ppstrm (name); pps " : "; ppType env ppstrm body;
191 :			pps " as ";
192 :			ppSequence ppstrm
193 :	macqueen	1344	{sep=C PrettyPrint.break{nsp=1,offset=0},
194 :	blume	902	pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),
195 :			style=CONSISTENT}
196 :			optl;
197 :	macqueen	1344	closeBox())
198 :	blume	902	| ppV(V.ERRORvar,_) = pps "<ERRORvar>"
199 :			in ppV
200 :			end
201 :
202 :			fun ppConBinding ppstrm =
203 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
204 :	blume	902	fun ppCon (T.DATACON{name, typ, rep=A.EXN _, ...}, env) =
205 :	macqueen	1344	(openHOVBox 4;
206 :	blume	902	pps "exception "; ppSym ppstrm name;
207 :			if BasicTypes.isArrowType typ then
208 :			(pps " of "; ppType env ppstrm (BasicTypes.domain typ))
209 :			else ();
210 :	macqueen	1344	closeBox())
211 :	blume	902	| ppCon (con as T.DATACON{name,typ,...},env) =
212 :			if !internals
213 :	macqueen	1344	then (openHOVBox 4;
214 :	blume	902	pps "datacon "; ppSym ppstrm name; pps " : ";
215 :			ppType env ppstrm typ;
216 :	macqueen	1344	closeBox())
217 :	blume	902	else ()
218 :			in ppCon
219 :			end
220 :
221 :			fun ppStructure ppstrm (str,env,depth) =
222 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
223 :	blume	902	in case str
224 :			of M.STR { sign, rlzn as { entities, ... }, ... } =>
225 :			(if !internals
226 :	macqueen	1344	then (openHVBox 2;
227 :	blume	902	pps "STR";
228 :			nl_indent ppstrm 2;
229 :	macqueen	1344	openHVBox 0;
230 :	blume	902	pps "sign:";
231 :	macqueen	1344	break {nsp=1,offset=2};
232 :	blume	902	ppSignature0 ppstrm (sign,env,depth-1,SOME entities);
233 :	macqueen	1344	newline();
234 :	blume	902	pps "rlzn:";
235 :	macqueen	1344	break {nsp=1,offset=2};
236 :	blume	902	ppStrEntity ppstrm (rlzn,env,depth-1);
237 :	macqueen	1344	closeBox();
238 :			closeBox())
239 :	blume	902	else case sign
240 :			of M.SIG { name = SOME sym, ... } =>
241 :			((if MU.eqSign
242 :			(sign,
243 :			LU.lookSig
244 :			(env,sym,(fn _ => raise SE.Unbound)))
245 :			then ppSym ppstrm sym
246 :			else (ppSym ppstrm sym; pps "?"))
247 :			handle SE.Unbound =>
248 :			(ppSym ppstrm sym; pps "?"))
249 :			| M.SIG { name = NONE, ... } =>
250 :			if depth <= 1 then pps "<sig>"
251 :			else ppSignature0 ppstrm
252 :			(sign,env,depth-1,SOME entities)
253 :			| M.ERRORsig => pps "<error sig>")
254 :			| M.STRSIG _ => pps "<strsig>"
255 :			| M.ERRORstr => pps "<error str>"
256 :			end
257 :
258 :			and ppElements (env,depth,entityEnvOp) ppstrm elements =
259 :			let fun pr first (sym,spec) =
260 :			case spec
261 :			of M.STRspec{sign,entVar,def,slot} =>
262 :	macqueen	1344	(if first then () else newline ppstrm;
263 :			openHVBox ppstrm (PP.Rel 0);
264 :			pps ppstrm "structure ";
265 :			ppSym ppstrm sym; pps ppstrm " :";
266 :			break ppstrm {nsp=1,offset=2};
267 :			openHVBox ppstrm (PP.Rel 0);
268 :	blume	902	case entityEnvOp
269 :			of NONE => ppSignature0 ppstrm (sign,env,depth-1,NONE)
270 :			| SOME eenv =>
271 :			let val {entities,...} =
272 :			case EE.look(eenv,entVar) of
273 :			M.STRent e => e
274 :			| _ => bug "ppElements:STRent"
275 :			in ppSignature0 ppstrm
276 :			(sign,env,depth-1,SOME entities)
277 :			end;
278 :			if !internals
279 :	macqueen	1344	then (newline ppstrm;
280 :			pps ppstrm "entVar: ";
281 :			pps ppstrm (EntPath.entVarToString entVar))
282 :	blume	902	else ();
283 :	macqueen	1344	closeBox ppstrm;
284 :			closeBox ppstrm)
285 :	blume	902
286 :			| M.FCTspec{sign,entVar,slot} =>
287 :	macqueen	1344	(if first then () else newline ppstrm;
288 :			openHVBox ppstrm (PP.Rel 0);
289 :			pps ppstrm "functor ";
290 :			ppSym ppstrm sym; pps ppstrm " :";
291 :			break ppstrm {nsp=1,offset=2};
292 :			openHVBox ppstrm (PP.Rel 0);
293 :	blume	902	ppFunsig ppstrm (sign,env,depth-1);
294 :			if !internals
295 :	macqueen	1344	then (newline ppstrm;
296 :			pps ppstrm "entVar: ";
297 :			pps ppstrm (EntPath.entVarToString entVar))
298 :	blume	902	else ();
299 :	macqueen	1344	closeBox ppstrm;
300 :			closeBox ppstrm)
301 :	blume	902
302 :			| M.TYCspec{spec,entVar,repl,scope} =>
303 :	macqueen	1344	(if first then () else newline ppstrm;
304 :			openHVBox ppstrm (PP.Rel 0);
305 :	blume	902	case entityEnvOp
306 :	macqueen	1344	of NONE =>
307 :			if repl then
308 :			ppReplBind ppstrm (spec,env)
309 :			else ppTycBind ppstrm (spec,env)
310 :	blume	902	| SOME eenv =>
311 :			(case EE.look(eenv,entVar)
312 :	macqueen	1344	of M.TYCent tyc =>
313 :			if repl then
314 :			ppReplBind ppstrm (tyc,env)
315 :			else ppTycBind ppstrm (tyc,env)
316 :			| M.ERRORent => pps ppstrm "<ERRORent>"
317 :	blume	902	| _ => bug "ppElements:TYCent");
318 :			if !internals
319 :	macqueen	1344	then (newline ppstrm;
320 :			pps ppstrm "entVar: ";
321 :			pps ppstrm (EntPath.entVarToString entVar);
322 :			newline ppstrm;
323 :			pps ppstrm "scope: ";
324 :			pps ppstrm (Int.toString scope))
325 :	blume	902	else ();
326 :	macqueen	1344	closeBox ppstrm)
327 :	blume	902
328 :			| M.VALspec{spec=typ,...} =>
329 :	macqueen	1344	(if first then () else newline ppstrm;
330 :			openHOVBox ppstrm (PP.Rel 4);
331 :			pps ppstrm "val ";
332 :			ppSym ppstrm sym; pps ppstrm " : ";
333 :	blume	902	ppType env ppstrm (typ);
334 :	macqueen	1344	closeBox ppstrm)
335 :	blume	902
336 :			| M.CONspec{spec=dcon as T.DATACON{rep=A.EXN _,...}, ...} =>
337 :	macqueen	1344	(if first then () else newline ppstrm;
338 :	blume	902	ppConBinding ppstrm (dcon,env))
339 :
340 :			| M.CONspec{spec=dcon,...} =>
341 :			if !internals
342 :	macqueen	1344	then (if first then () else newline ppstrm;
343 :	blume	902	ppConBinding ppstrm (dcon,env))
344 :			else () (* ordinary data constructor, don't print *)
345 :
346 :	macqueen	1344	in openHVBox ppstrm (PP.Rel 0);
347 :	blume	902	case elements
348 :			of nil => ()
349 :			| first :: rest => (pr true first; app (pr false) rest);
350 :	macqueen	1344	closeBox ppstrm
351 :	blume	902	end
352 :
353 :			and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
354 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
355 :	blume	902	val env = SE.atop(case entityEnvOp
356 :			of NONE => sigToEnv sign
357 :			| SOME entEnv => strToEnv(sign,entEnv),
358 :			env)
359 :			fun ppConstraints (variety,constraints : M.sharespec list) =
360 :	macqueen	1344	(openHVBox 0;
361 :	blume	902	ppvseq ppstrm 0 ""
362 :			(fn ppstrm => fn paths =>
363 :	macqueen	1344	(openHOVBox 2;
364 :	blume	902	pps "sharing "; pps variety;
365 :			ppSequence ppstrm
366 :			{sep=(fn ppstrm =>
367 :	macqueen	1344	(pps " ="; break{nsp=1,offset=0})),
368 :	blume	902	pr=ppSymPath,
369 :			style=INCONSISTENT}
370 :			paths;
371 :	macqueen	1344	closeBox()))
372 :	blume	902	constraints;
373 :	macqueen	1344	closeBox ())
374 :	blume	902	val somePrint = ref false
375 :			in if depth <= 0
376 :			then pps "<sig>"
377 :			else
378 :			case sign
379 :			of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
380 :			if !internals then
381 :	macqueen	1344	(openHVBox 0;
382 :	blume	902	pps "SIG:";
383 :			nl_indent ppstrm 2;
384 :	macqueen	1344	openHVBox 0;
385 :	blume	902	pps "stamp: "; pps (Stamps.toShortString stamp);
386 :	macqueen	1344	newline();
387 :	blume	902	pps "name: ";
388 :			case name
389 :			of NONE => pps "ANONYMOUS"
390 :			| SOME p => (pps "NAMED "; ppSym ppstrm p);
391 :			case elements
392 :			of nil => ()
393 :	macqueen	1344	| _ => (newline(); pps "elements:";
394 :	blume	902	nl_indent ppstrm 2;
395 :			ppElements (env,depth,entityEnvOp) ppstrm elements);
396 :			case strsharing
397 :			of nil => ()
398 :	macqueen	1344	| _ => (newline(); pps "strsharing:";
399 :	blume	902	nl_indent ppstrm 2;
400 :			ppConstraints("",strsharing));
401 :			case typsharing
402 :			of nil => ()
403 :	macqueen	1344	| _ => (newline(); pps "tycsharing:";
404 :	blume	902	nl_indent ppstrm 2;
405 :			ppConstraints("type ",typsharing));
406 :	macqueen	1344	closeBox();
407 :			closeBox())
408 :	blume	902	else (* not !internals *)
409 :	macqueen	1344	(openHVBox 0;
410 :	blume	902	pps "sig";
411 :	macqueen	1344	break{nsp=1,offset=2};
412 :			openHVBox 0;
413 :	blume	902	case elements
414 :			of nil => ()
415 :			| _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;
416 :			somePrint := true);
417 :			case strsharing
418 :			of nil => ()
419 :	macqueen	1344	| _ => (if !somePrint then newline() else ();
420 :	blume	902	ppConstraints("",strsharing);
421 :			somePrint := true);
422 :			case typsharing
423 :			of nil => ()
424 :	macqueen	1344	| _ => (if !somePrint then newline() else ();
425 :	blume	902	ppConstraints("type ",typsharing);
426 :			somePrint := true);
427 :	macqueen	1344	closeBox();
428 :			if !somePrint then break{nsp=1,offset=0} else ();
429 :	blume	902	pps "end";
430 :	macqueen	1344	closeBox())
431 :	blume	902	| M.ERRORsig => pps "<error sig>"
432 :			end
433 :
434 :			and ppFunsig ppstrm (sign,env,depth) =
435 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
436 :	blume	902	fun trueBodySig (orig as M.SIG { elements =
437 :			[(sym, M.STRspec { sign, ... })],
438 :			... }) =
439 :			if Symbol.eq (sym, resultId) then sign else orig
440 :			| trueBodySig orig = orig
441 :			in if depth<=0 then pps "<fctsig>"
442 :			else case sign
443 :			of M.FSIG {paramsig,paramvar,paramsym,bodysig, ...} =>
444 :			if !internals
445 :	macqueen	1344	then (openHVBox 0;
446 :	blume	902	pps "FSIG:";
447 :			nl_indent ppstrm 2;
448 :	macqueen	1344	openHVBox 0;
449 :	blume	902	pps "psig: ";
450 :			ppSignature0 ppstrm (paramsig,env,depth-1,NONE);
451 :	macqueen	1344	newline();
452 :	blume	902	pps "pvar: ";
453 :			pps (EntPath.entVarToString paramvar);
454 :	macqueen	1344	newline();
455 :	blume	902	pps "psym: ";
456 :			(case paramsym
457 :			of NONE => pps "<anonymous>"
458 :			| SOME sym => ppSym ppstrm sym);
459 :	macqueen	1344	newline();
460 :	blume	902	pps "bsig: ";
461 :			ppSignature0 ppstrm (bodysig,env,depth-1,NONE);
462 :	macqueen	1344	closeBox();
463 :			closeBox())
464 :			else (openHVBox 0;
465 :	blume	902	pps "(";
466 :			case paramsym
467 :			of SOME x => pps (S.name x)
468 :			| _ => pps "<param>";
469 :			pps ": ";
470 :			ppSignature0 ppstrm (paramsig,env,depth-1,NONE);
471 :			pps ") :";
472 :	macqueen	1344	break{nsp=1,offset=0};
473 :	blume	902	ppSignature0 ppstrm
474 :			(trueBodySig bodysig,env,depth-1,NONE);
475 :	macqueen	1344	closeBox())
476 :	blume	902	| M.ERRORfsig => pps "<error fsig>"
477 :			end
478 :
479 :
480 :			and ppStrEntity ppstrm (e,env,depth) =
481 :			let val {stamp,entities,properties,rpath,stub} = e
482 :	macqueen	1344	val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
483 :	blume	902	in if depth <= 1
484 :			then pps "<structure entity>"
485 :	macqueen	1344	else (openHVBox 0;
486 :	blume	902	pps "strEntity:";
487 :			nl_indent ppstrm 2;
488 :	macqueen	1344	openHVBox 0;
489 :	blume	902	pps "rpath: ";
490 :			pps (IP.toString rpath);
491 :	macqueen	1344	newline();
492 :	blume	902	pps "stamp: ";
493 :			pps (Stamps.toShortString stamp);
494 :	macqueen	1344	newline();
495 :	blume	902	pps "entities:";
496 :			nl_indent ppstrm 2;
497 :			ppEntityEnv ppstrm (entities,env,depth-1);
498 :	macqueen	1344	newline();
499 :	blume	902	pps "lambdaty:";
500 :			nl_indent ppstrm 2;
501 :			ppLty ppstrm ( (* ModulePropLists.strEntityLty e,depth-1 *));
502 :	macqueen	1344	closeBox ();
503 :			closeBox ())
504 :	blume	902	end
505 :
506 :			and ppFctEntity ppstrm (e, env, depth) =
507 :			let val {stamp,closure,properties,tycpath,rpath,stub} = e
508 :	macqueen	1344	val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
509 :	blume	902	in if depth <= 1
510 :			then pps "<functor entity>"
511 :	macqueen	1344	else (openHVBox 0;
512 :	blume	902	pps "fctEntity:";
513 :			nl_indent ppstrm 2;
514 :	macqueen	1344	openHVBox 0;
515 :	blume	902	pps "rpath: ";
516 :			pps (IP.toString rpath);
517 :	macqueen	1344	newline();
518 :	blume	902	pps "stamp: ";
519 :			pps (Stamps.toShortString stamp);
520 :	macqueen	1344	newline();
521 :	blume	902	pps "closure:";
522 :	macqueen	1344	break{nsp=1,offset=2};
523 :	blume	902	ppClosure ppstrm (closure,depth-1);
524 :	macqueen	1344	newline();
525 :	blume	902	pps "lambdaty:";
526 :	macqueen	1344	break{nsp=1,offset=2};
527 :	blume	902	ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );
528 :			pps "tycpath:";
529 :	macqueen	1344	break{nsp=1,offset=2};
530 :	blume	902	pps "--printing of tycpath not implemented yet--";
531 :	macqueen	1344	closeBox ();
532 :			closeBox ())
533 :	blume	902	end
534 :
535 :			and ppFunctor ppstrm =
536 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
537 :	blume	902	fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =
538 :			if depth <= 1
539 :			then pps "<functor>"
540 :	macqueen	1344	else (openHVBox 0;
541 :	blume	902	pps "sign:";
542 :			nl_indent ppstrm 2;
543 :			ppFunsig ppstrm (sign,env,depth-1);
544 :	macqueen	1344	newline();
545 :	blume	902	pps "rlzn:";
546 :			nl_indent ppstrm 2;
547 :			ppFctEntity ppstrm (rlzn,env,depth-1);
548 :	macqueen	1344	closeBox ())
549 :	blume	902	| ppF (M.ERRORfct,_,_) = pps "<error functor>"
550 :			in ppF
551 :			end
552 :
553 :			and ppTycBind ppstrm (tyc,env) =
554 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
555 :	blume	902	fun visibleDcons(tyc,dcons) =
556 :			let fun checkCON(V.CON c) = c
557 :			| checkCON _ = raise SE.Unbound
558 :			fun find ((actual as {name,rep,domain}) :: rest) =
559 :			(let val found =
560 :			checkCON(LU.lookValSym
561 :			(env,name,
562 :			fn _ => raise SE.Unbound))
563 :			in (* test whether the datatypes of actual and
564 :			found constructor agree *)
565 :			case TU.dconTyc found
566 :			of tyc1 as T.GENtyc _ =>
567 :			(* the expected form in structures *)
568 :			if TU.eqTycon(tyc,tyc1)
569 :			then found :: find rest
570 :			else find rest
571 :			| T.PATHtyc _ =>
572 :			(* the expected form in signatures;
573 :			we won't check visibility [dbm] *)
574 :			found :: find rest
575 :			| d_found =>
576 :			(* something's weird *)
577 :			let val old_internals = !internals
578 :			in internals := true;
579 :	macqueen	1344	openHVBox 0;
580 :	blume	902	pps "ppTycBind failure: ";
581 :	macqueen	1344	newline();
582 :	blume	902	ppTycon env ppstrm tyc;
583 :	macqueen	1344	newline();
584 :	blume	902	ppTycon env ppstrm d_found;
585 :	macqueen	1344	newline();
586 :			closeBox();
587 :	blume	902	internals := old_internals;
588 :			find rest
589 :			end
590 :			end
591 :			handle SE.Unbound => find rest)
592 :			| find [] = []
593 :			in find dcons
594 :			end
595 :			fun stripPoly(T.POLYty{tyfun=T.TYFUN{body,...},...}) = body
596 :			| stripPoly ty = ty
597 :			fun ppDcon (T.DATACON{name,typ,...}) =
598 :			(ppSym ppstrm name;
599 :			let val typ = stripPoly typ
600 :			in if BT.isArrowType typ
601 :			then (pps " of "; ppType env ppstrm (BT.domain typ))
602 :			else ()
603 :			end)
604 :			in if !internals
605 :	macqueen	1344	then (openHVBox 0;
606 :	blume	902	pps "type "; ppTycon env ppstrm tyc;
607 :	macqueen	1344	closeBox())
608 :	blume	902	else
609 :			case tyc of
610 :			T.GENtyc { path, arity, eq, kind, ... } =>
611 :			(case (!eq, kind) of
612 :			(T.ABS, _) =>
613 :			(* abstype *)
614 :	macqueen	1344	(openHVBox 0;
615 :	blume	902	pps "type";
616 :			ppFormals ppstrm arity;
617 :			pps " ";
618 :			ppSym ppstrm (IP.last path);
619 :	macqueen	1344	closeBox())
620 :	blume	902	| (_, T.DATATYPE{index,family={members,...},...}) =>
621 :			(* ordinary datatype *)
622 :			let val {dcons,...} = Vector.sub(members,index)
623 :			val visdcons = visibleDcons(tyc,dcons)
624 :			val incomplete = length visdcons < length dcons
625 :			in
626 :	macqueen	1344	openHVBox 0;
627 :	blume	902	pps "datatype";
628 :			ppFormals ppstrm arity;
629 :			pps " ";
630 :			ppSym ppstrm (IP.last path);
631 :			case visdcons
632 :			of nil => pps " = ..."
633 :			| first :: rest =>
634 :	macqueen	1344	(break{nsp=1,offset=2};
635 :			openHVBox 0;
636 :	blume	902	pps "= "; ppDcon first;
637 :	macqueen	1344	app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))
638 :	blume	902	rest;
639 :			if incomplete
640 :	macqueen	1344	then (break{nsp=1,offset=0}; pps "... ")
641 :	blume	902	else ();
642 :	macqueen	1344	closeBox());
643 :			closeBox()
644 :	blume	902	end
645 :			| _ =>
646 :	macqueen	1344	(openHVBox 0;
647 :	blume	902	if EqTypes.isEqTycon tyc
648 :			then pps "eqtype"
649 :			else pps "type";
650 :			ppFormals ppstrm arity;
651 :			pps " ";
652 :			ppSym ppstrm (IP.last path);
653 :	macqueen	1344	closeBox()))
654 :	blume	902	| T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>
655 :	macqueen	1344	(openHOVBox 2;
656 :	blume	902	pps "type";
657 :			ppFormals ppstrm arity;
658 :	macqueen	1344	break{nsp=1,offset=0};
659 :	blume	902	ppSym ppstrm (InvPath.last path);
660 :			pps " =";
661 :	macqueen	1344	break{nsp=1,offset=0};
662 :	blume	902	ppType env ppstrm body;
663 :	macqueen	1344	closeBox ())
664 :	blume	902	| tycon =>
665 :			(pps "strange tycon: ";
666 :			ppTycon env ppstrm tycon)
667 :			end (* ppTycBind *)
668 :
669 :	macqueen	1344	and ppReplBind ppstrm
670 :			(T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =
671 :			let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
672 :			in openHOVBox 2;
673 :			pps "datatype"; break{nsp=1,offset=0};
674 :			ppSym ppstrm (IP.last path);
675 :			pps " ="; break{nsp=1,offset=0};
676 :			pps "datatype"; break{nsp=1,offset=0};
677 :			ppTycon env ppstrm rightTyc;
678 :			closeBox ()
679 :			end
680 :			| ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"
681 :
682 :	blume	902	and ppEntity ppstrm (entity,env,depth) =
683 :			case entity
684 :			of M.TYCent tycon => ppTycon env ppstrm tycon
685 :			| M.STRent strEntity => ppStrEntity ppstrm (strEntity,env,depth-1)
686 :			| M.FCTent fctEntity => ppFctEntity ppstrm (fctEntity,env,depth-1)
687 :	macqueen	1344	| M.ERRORent => pps ppstrm "ERRORent"
688 :	blume	902
689 :			and ppEntityEnv ppstrm (entEnv,env,depth) =
690 :			if depth <= 1
691 :	macqueen	1344	then pps ppstrm "<entityEnv>"
692 :	blume	902	else (ppvseq ppstrm 2 ""
693 :			(fn ppstrm => fn (entVar,entity) =>
694 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,break,newline} =
695 :	blume	902	en_pp ppstrm
696 :	macqueen	1344	in openHVBox 2;
697 :	blume	902	pps (EntPath.entVarToString entVar);
698 :			pps ":";
699 :			nl_indent ppstrm 2;
700 :			ppEntity ppstrm (entity,env,depth-1);
701 :	macqueen	1344	newline();
702 :			closeBox()
703 :	blume	902	end)
704 :			(EE.toList entEnv))
705 :
706 :			and ppEntDec ppstrm (entDec,depth) =
707 :	macqueen	1344	if depth <= 0 then pps ppstrm "<entDec>"
708 :	blume	902	else case entDec
709 :			of M.TYCdec(entVar,tycExp) =>
710 :	macqueen	1344	(pps ppstrm "ED.T: ";
711 :			ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
712 :	blume	902	ppTycExp ppstrm (tycExp,depth-1))
713 :			| M.STRdec(entVar,strExp,sym) =>
714 :	macqueen	1344	(pps ppstrm "ED.S: ";
715 :			ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
716 :			ppStrExp ppstrm (strExp,depth-1); break ppstrm {nsp=1,offset=1};
717 :	blume	902	ppSym ppstrm sym)
718 :			| M.FCTdec(entVar,fctExp) =>
719 :	macqueen	1344	(pps ppstrm "ED.F: ";
720 :			ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
721 :	blume	902	ppFctExp ppstrm (fctExp,depth-1))
722 :			| M.SEQdec entityDecs =>
723 :			ppvseq ppstrm 0 ""
724 :			(fn ppstrm => fn entDec => ppEntDec ppstrm (entDec,depth))
725 :			entityDecs
726 :	macqueen	1344	| M.LOCALdec(entityDecL,entityDecB) => pps ppstrm "ED.L:"
727 :			| M.ERRORdec => pps ppstrm "ED.ER:"
728 :			| M.EMPTYdec => pps ppstrm "ED.EM:"
729 :	blume	902
730 :			and ppStrExp ppstrm (strExp,depth) =
731 :	macqueen	1344	if depth <= 0 then pps ppstrm "<strExp>" else
732 :	blume	902	case strExp
733 :			of M.VARstr ep =>
734 :	macqueen	1344	(pps ppstrm "SE.V:"; break ppstrm {nsp=1,offset=1};
735 :	blume	902	ppEntPath ppstrm ep)
736 :			| M.CONSTstr { stamp, rpath, ... } =>
737 :	macqueen	1344	(pps ppstrm "SE.C:"; break ppstrm {nsp=1,offset=1};
738 :	blume	902	ppInvPath ppstrm rpath)
739 :			| M.STRUCTURE{stamp,entDec} =>
740 :	macqueen	1344	(pps ppstrm "SE.S:"; break ppstrm {nsp=1,offset=1};
741 :	blume	902	ppEntDec ppstrm (entDec,depth-1))
742 :			| M.APPLY(fctExp,strExp) =>
743 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
744 :			pps ppstrm "SE.AP:"; break ppstrm {nsp=1,offset=1};
745 :			openHVBox ppstrm (PP.Rel 0);
746 :			pps ppstrm "fct:"; ppFctExp ppstrm (fctExp, depth -1);
747 :			break ppstrm {nsp=1,offset=0};
748 :			pps ppstrm "arg:"; ppStrExp ppstrm (strExp, depth -1);
749 :			closeBox ppstrm;
750 :			closeBox ppstrm)
751 :	blume	902	| M.LETstr(entDec,strExp) =>
752 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
753 :			pps ppstrm "SE.L:"; break ppstrm {nsp=1,offset=1};
754 :			openHVBox ppstrm (PP.Rel 0);
755 :			pps ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);
756 :			break ppstrm {nsp=1,offset=0};
757 :			pps ppstrm "in:"; ppStrExp ppstrm (strExp, depth -1);
758 :			closeBox ppstrm;
759 :			closeBox ppstrm)
760 :	blume	902	| M.ABSstr(sign,strExp) =>
761 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
762 :			pps ppstrm "SE.AB:"; break ppstrm {nsp=1,offset=1};
763 :			openHVBox ppstrm (PP.Rel 0);
764 :			pps ppstrm "sign: <omitted>";
765 :			break ppstrm {nsp=1,offset=0};
766 :			pps ppstrm "sexp:"; ppStrExp ppstrm (strExp, depth -1);
767 :			closeBox ppstrm;
768 :			closeBox ppstrm)
769 :	blume	902	| M.CONSTRAINstr{boundvar,raw,coercion} =>
770 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
771 :			pps ppstrm "SE.CO:"; break ppstrm {nsp=1,offset=1};
772 :			openHVBox ppstrm (PP.Rel 0);
773 :			ppEntVar ppstrm boundvar; break ppstrm {nsp=1,offset=1};
774 :			pps ppstrm "src:"; ppStrExp ppstrm (raw, depth -1);
775 :			break ppstrm {nsp=1,offset=0};
776 :			pps ppstrm "tgt:"; ppStrExp ppstrm (coercion, depth -1);
777 :			closeBox ppstrm;
778 :			closeBox ppstrm)
779 :			| M.FORMstr(sign) => pps ppstrm "SE.FM:"
780 :	blume	902
781 :			and ppFctExp ppstrm (fctExp,depth) =
782 :	macqueen	1344	if depth <= 0 then pps ppstrm "<fctExp>" else
783 :	blume	902	case fctExp
784 :			of M.VARfct ep =>
785 :	macqueen	1344	(pps ppstrm "FE.V:"; ppEntPath ppstrm ep)
786 :	blume	902	| M.CONSTfct { rpath, ... } =>
787 :	macqueen	1344	(pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)
788 :	blume	902	| M.LAMBDA_TP {param, body, ...} =>
789 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
790 :			pps ppstrm "FE.LP:"; break ppstrm {nsp=1,offset=1};
791 :			openHVBox ppstrm (PP.Rel 0);
792 :			pps ppstrm "par:"; ppEntVar ppstrm param;
793 :			break ppstrm {nsp=1,offset=0};
794 :			pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
795 :			closeBox ppstrm;
796 :			closeBox ppstrm)
797 :	blume	902	| M.LAMBDA {param, body} =>
798 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
799 :			pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};
800 :			openHVBox ppstrm (PP.Rel 0);
801 :			pps ppstrm "par:"; ppEntVar ppstrm param;
802 :			break ppstrm {nsp=1,offset=0};
803 :			pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
804 :			closeBox ppstrm;
805 :			closeBox ppstrm)
806 :	blume	902	| M.LETfct (entDec,fctExp) =>
807 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
808 :			pps ppstrm "FE.LT:"; break ppstrm {nsp=1,offset=1};
809 :			openHVBox ppstrm (PP.Rel 0);
810 :			pps ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);
811 :			break ppstrm {nsp=1,offset=0};
812 :			pps ppstrm "in:"; ppFctExp ppstrm (fctExp, depth -1);
813 :			closeBox ppstrm;
814 :			closeBox ppstrm)
815 :	blume	902
816 :			(*
817 :			and ppBodyExp ppstrm (bodyExp,depth) =
818 :	macqueen	1344	if depth <= 0 then pps ppstrm "<bodyExp>" else
819 :	blume	902	case bodyExp
820 :	macqueen	1344	of M.FLEX sign => pps ppstrm "BE.F:"
821 :	blume	902	| M.OPAQ (sign,strExp) =>
822 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
823 :			pps ppstrm "BE.O:"; break ppstrm {nsp=1,offset=1};
824 :	blume	902	ppStrExp ppstrm (strExp,depth-1);
825 :	macqueen	1344	closeBox ppstrm)
826 :	blume	902	| M.TNSP (sign,strExp) =>
827 :	macqueen	1344	(openHVBox ppstrm (PP.Rel 0);
828 :			pps ppstrm "BE.T:"; break ppstrm {nsp=1,offset=1};
829 :	blume	902	ppStrExp ppstrm (strExp,depth-1);
830 :	macqueen	1344	closeBox ppstrm)
831 :	blume	902
832 :			*)
833 :
834 :			and ppClosure ppstrm (M.CLOSURE{param,body,env},depth) =
835 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,newline,break,...} = en_pp ppstrm
836 :			in openHVBox 0;
837 :			pps "CL:"; break{nsp=1,offset=1};
838 :			openHVBox 0;
839 :			pps "param: "; ppEntVar ppstrm param; newline();
840 :			pps "body: "; ppStrExp ppstrm (body,depth-1); newline();
841 :	blume	902	pps "env: "; ppEntityEnv ppstrm (env,SE.empty,depth-1);
842 :	macqueen	1344	closeBox();
843 :			closeBox()
844 :	blume	902	end
845 :
846 :			(* assumes no newline is needed before pping *)
847 :			and ppBinding ppstrm (name,binding:B.binding,env:SE.staticEnv,depth:int) =
848 :			case binding
849 :			of B.VALbind var => (pps ppstrm "val "; ppVariable ppstrm (var,env))
850 :			| B.CONbind con => ppConBinding ppstrm (con,env)
851 :			| B.TYCbind tycon => ppTycBind ppstrm (tycon,env)
852 :			| B.SIGbind sign =>
853 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
854 :			in openHVBox 0;
855 :	blume	902	pps "signature "; ppSym ppstrm name; pps " =";
856 :	macqueen	1344	break{nsp=1,offset=2};
857 :	blume	902	ppSignature0 ppstrm (sign,env,depth,NONE);
858 :	macqueen	1344	closeBox()
859 :	blume	902	end
860 :			| B.FSGbind fs =>
861 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,...} = en_pp ppstrm
862 :			in openHVBox 2;
863 :	blume	902	pps "funsig "; ppSym ppstrm name;
864 :			ppFunsig ppstrm (fs,env,depth);
865 :	macqueen	1344	closeBox()
866 :	blume	902	end
867 :			| B.STRbind str =>
868 :	macqueen	1344	let val {openHVBox, openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
869 :			in openHVBox 0;
870 :	blume	902	pps "structure "; ppSym ppstrm name; pps " :";
871 :	macqueen	1344	break{nsp=1,offset=2};
872 :	blume	902	ppStructure ppstrm (str,env,depth);
873 :	macqueen	1344	closeBox()
874 :	blume	902	end
875 :			| B.FCTbind fct =>
876 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,...} = en_pp ppstrm
877 :			in openHVBox 0;
878 :	blume	902	pps "functor ";
879 :			ppSym ppstrm name;
880 :			pps " : <sig>"; (* DBM -- should print the signature *)
881 :	macqueen	1344	closeBox()
882 :	blume	902	end
883 :			| B.FIXbind fixity =>
884 :			(pps ppstrm (Fixity.fixityToString fixity); ppSym ppstrm name)
885 :
886 :			(* ppEnv: pp an environment in the context of the top environment.
887 :			The environment must either be for a signature or be absolute (i.e.
888 :			all types and structures have been interpreted) *)
889 :			(* Note: I make a preliminary pass over bindings to remove
890 :			invisible ConBindings -- Konrad.
891 :			and invisible structures too -- PC *)
892 :			and ppEnv ppstrm (env,topenv,depth,boundsyms) =
893 :			let val bindings =
894 :			case boundsyms
895 :			of NONE => SE.sort env
896 :			| SOME l => foldr (fn (x,bs) =>
897 :			((x,SE.look(env,x))::bs
898 :			handle SE.Unbound => bs))
899 :			[] l
900 :			val pp_env = StaticEnv.atop(env,topenv)
901 :			in ppSequence ppstrm
902 :	macqueen	1344	{sep=newline,
903 :	blume	902	pr=(fn ppstrm => fn (name,binding) =>
904 :			ppBinding ppstrm (name,binding,pp_env,depth)),
905 :			style=CONSISTENT}
906 :			(all_ppable_bindings bindings pp_env)
907 :			end
908 :
909 :			fun ppOpen ppstrm (path,str,env,depth) =
910 :	macqueen	1344	let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
911 :			in openHVBox 0;
912 :			openHVBox 2;
913 :			pps "opening ";
914 :	blume	902	ppSymPath ppstrm path;
915 :			if depth < 1 then ()
916 :			else (case str
917 :			of M.STR { sign, rlzn as {entities,...}, ... } =>
918 :			(case sign
919 :			of M.SIG {elements = [],...} => ()
920 :			| M.SIG {elements,...} =>
921 :	macqueen	1344	(newline ();
922 :			openHVBox 0;
923 :	blume	902	ppElements (SE.atop(sigToEnv sign, env),
924 :			depth,SOME entities)
925 :			ppstrm elements;
926 :	macqueen	1344	closeBox ())
927 :	blume	902	| M.ERRORsig => ())
928 :			| M.ERRORstr => ()
929 :			| M.STRSIG _ => bug "ppOpen");
930 :	macqueen	1344	closeBox ();
931 :			newline();
932 :			closeBox ()
933 :	blume	902	end
934 :
935 :			fun ppSignature ppstrm (sign,env,depth) =
936 :			ppSignature0 ppstrm (sign,env,depth,NONE)
937 :
938 :			end (* local *)
939 :			end (* structure PPModules *)

---

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