Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Elaborator/print/ppmod.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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