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/MiscUtil/print/ppmod.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 113 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/MiscUtil/print/ppmod.sml

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

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