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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 902 - (view) (download)

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

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