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/branches/primop-branch-3/compiler/Elaborator/print/ppmod.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/Elaborator/print/ppmod.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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