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

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