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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1343, Wed Aug 13 17:44:22 2003 UTC revision 1344, Wed Aug 13 18:04:08 2003 UTC
# Line 1  Line 1 
1  (* Copyright 1996 by AT&T Bell Laboratories *)  (* Copyright 1996 by AT&T Bell Laboratories *)
2    (* Copyright 2003 by The SML/NJ Fellowship *)
3  (* ppmod.sml *)  (* ppmod.sml *)
4    
5    (* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6    
7  signature PPMOD =  signature PPMOD =
8  sig  sig
9    val ppSignature: PrettyPrint.ppstream    val ppSignature: PrettyPrint.stream
10          -> Modules.Signature * StaticEnv.staticEnv * int -> unit          -> Modules.Signature * StaticEnv.staticEnv * int -> unit
11    val ppStructure: PrettyPrint.ppstream    val ppStructure: PrettyPrint.stream
12          -> Modules.Structure * StaticEnv.staticEnv * int -> unit          -> Modules.Structure * StaticEnv.staticEnv * int -> unit
13    val ppOpen: PrettyPrint.ppstream    val ppOpen: PrettyPrint.stream
14          -> SymPath.path * Modules.Structure * StaticEnv.staticEnv * int -> unit          -> SymPath.path * Modules.Structure * StaticEnv.staticEnv * int -> unit
15    val ppStructureName : PrettyPrint.ppstream    val ppStructureName : PrettyPrint.stream
16          -> Modules.Structure * StaticEnv.staticEnv -> unit          -> Modules.Structure * StaticEnv.staticEnv -> unit
17    val ppFunctor : PrettyPrint.ppstream    val ppFunctor : PrettyPrint.stream
18          -> Modules.Functor * StaticEnv.staticEnv * int -> unit          -> Modules.Functor * StaticEnv.staticEnv * int -> unit
19    val ppFunsig : PrettyPrint.ppstream    val ppFunsig : PrettyPrint.stream
20          -> Modules.fctSig * StaticEnv.staticEnv * int -> unit          -> Modules.fctSig * StaticEnv.staticEnv * int -> unit
21    val ppBinding: PrettyPrint.ppstream    val ppBinding: PrettyPrint.stream
22          -> Symbol.symbol * Bindings.binding * StaticEnv.staticEnv * int          -> Symbol.symbol * Bindings.binding * StaticEnv.staticEnv * int
23               -> unit               -> unit
24    val ppEnv : PrettyPrint.ppstream    val ppEnv : PrettyPrint.stream
25                -> StaticEnv.staticEnv * StaticEnv.staticEnv * int *                -> StaticEnv.staticEnv * StaticEnv.staticEnv * int *
26                   Symbol.symbol list option                   Symbol.symbol list option
27                -> unit                -> unit
# Line 26  Line 29 
29    (* module internals *)    (* module internals *)
30    
31    val ppElements : (StaticEnv.staticEnv * int * Modules.entityEnv option)    val ppElements : (StaticEnv.staticEnv * int * Modules.entityEnv option)
32                     -> PrettyPrint.ppstream                     -> PrettyPrint.stream
33                     -> Modules.elements -> unit                     -> Modules.elements -> unit
34    
35    val ppEntity : PrettyPrint.ppstream    val ppEntity : PrettyPrint.stream
36                   -> Modules.entity * StaticEnv.staticEnv * int                   -> Modules.entity * StaticEnv.staticEnv * int
37                   -> unit                   -> unit
38    
39    val ppEntityEnv : PrettyPrint.ppstream    val ppEntityEnv : PrettyPrint.stream
40                      -> Modules.entityEnv * StaticEnv.staticEnv * int                      -> Modules.entityEnv * StaticEnv.staticEnv * int
41                      -> unit                      -> unit
42    
# Line 68  Line 71 
71  fun bug msg = ErrorMsg.impossible("PPModules: "^msg)  fun bug msg = ErrorMsg.impossible("PPModules: "^msg)
72  fun C f x y = f y x;  fun C f x y = f y x;
73    
74  val pps = PP.add_string  val pps = PP.string
75  val ppType = PPType.ppType  val ppType = PPType.ppType
76  val ppTycon = PPType.ppTycon  val ppTycon = PPType.ppTycon
77  val ppTyfun = PPType.ppTyfun  val ppTyfun = PPType.ppTyfun
# Line 134  Line 137 
137                  alist                  alist
138    
139    
140  fun ppLty ppstrm ( (* lambdaty,depth *) ) =  add_string ppstrm "<lambdaty>"  fun ppLty ppstrm ( (* lambdaty,depth *) ) =  pps ppstrm "<lambdaty>"
141    
142  fun ppEntVar ppstrm entVar =  fun ppEntVar ppstrm entVar =
143      add_string ppstrm (EntPath.entVarToString entVar)      pps ppstrm (EntPath.entVarToString entVar)
144    
145  fun ppEntPath ppstrm entPath =  fun ppEntPath ppstrm entPath =
146      add_string ppstrm (EntPath.entPathToString entPath)      pps ppstrm (EntPath.entPathToString entPath)
147  (*    ppClosedSequence ppstream  (*    ppClosedSequence ppstream
148        {front=(fn pps => add_string pps "["),        {front=(fn ppstrm => pps ppstrm "["),
149         sep=(fn pps => (add_string pps ","; add_break pps (0,0))),         sep=(fn ppstrm => (pps ppstrm ","; break ppstrm {nsp=0,offset=0})),
150         back=(fn pps => add_string pps "]"),         back=(fn ppstrm => pps ppstrm "]"),
151         style=INCONSISTENT,         style=INCONSISTENT,
152         pr=ppEntVar}         pr=ppEntVar}
153  *)  *)
154    
155  fun ppTycExp ppstrm (tycExp,depth) =  fun ppTycExp ppstrm (tycExp,depth) =
156      if depth <= 0 then add_string ppstrm "<tycExp>" else      if depth <= 0 then pps ppstrm "<tycExp>" else
157      case tycExp      case tycExp
158        of M.VARtyc ep =>        of M.VARtyc ep =>
159            (add_string ppstrm "TE.V:"; add_break ppstrm (1,1);            (pps ppstrm "TE.V:"; break ppstrm {nsp=1,offset=1};
160             ppEntPath ppstrm ep)             ppEntPath ppstrm ep)
161         | M.CONSTtyc tycon =>         | M.CONSTtyc tycon =>
162            (add_string ppstrm "TE.C:"; add_break ppstrm (1,1);            (pps ppstrm "TE.C:"; break ppstrm {nsp=1,offset=1};
163             ppTycon SE.empty ppstrm tycon)             ppTycon SE.empty ppstrm tycon)
164         | M.FORMtyc tycon =>         | M.FORMtyc tycon =>
165            (add_string ppstrm "TE.FM:"; add_break ppstrm (1,1);            (pps ppstrm "TE.FM:"; break ppstrm {nsp=1,offset=1};
166             ppTycon SE.empty ppstrm tycon)             ppTycon SE.empty ppstrm tycon)
167    
168  fun ppStructureName ppstrm (str,env) =  fun ppStructureName ppstrm (str,env) =
# Line 175  Line 178 
178      end      end
179    
180  fun ppVariable ppstrm  =  fun ppVariable ppstrm  =
181      let val {begin_block,end_block,pps,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
182          fun ppV(V.VALvar{path,access,typ,info},env:StaticEnv.staticEnv) =          fun ppV(V.VALvar{path,access,typ,info},env:StaticEnv.staticEnv) =
183                (begin_block CONSISTENT 0;                (openHVBox 0;
184                 pps(SP.toString path);                 pps(SP.toString path);
185                 if !internals then PPVal.ppAccess ppstrm access else ();                 if !internals then PPVal.ppAccess ppstrm access else ();
186                 pps " : "; ppType env ppstrm (!typ);                 pps " : "; ppType env ppstrm (!typ);
187                 end_block())                 closeBox())
188            | ppV (V.OVLDvar {name,options=ref optl,scheme=T.TYFUN{body,...}},env) =            | ppV (V.OVLDvar {name,options=ref optl,scheme=T.TYFUN{body,...}},env) =
189                (begin_block CONSISTENT 0;                (openHVBox 0;
190                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;
191                 pps " as ";                 pps " as ";
192                 ppSequence ppstrm                 ppSequence ppstrm
193                   {sep=C PrettyPrint.add_break(1,0),                   {sep=C PrettyPrint.break{nsp=1,offset=0},
194                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),
195                    style=CONSISTENT}                    style=CONSISTENT}
196                   optl;                   optl;
197                 end_block())                 closeBox())
198            | ppV(V.ERRORvar,_) = pps "<ERRORvar>"            | ppV(V.ERRORvar,_) = pps "<ERRORvar>"
199       in ppV       in ppV
200      end      end
201    
202  fun ppConBinding ppstrm =  fun ppConBinding ppstrm =
203      let val {begin_block,end_block,pps,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
204          fun ppCon (T.DATACON{name, typ, rep=A.EXN _, ...}, env) =          fun ppCon (T.DATACON{name, typ, rep=A.EXN _, ...}, env) =
205                (begin_block INCONSISTENT 4;                (openHOVBox 4;
206                 pps "exception "; ppSym ppstrm name;                 pps "exception "; ppSym ppstrm name;
207                 if BasicTypes.isArrowType typ then                 if BasicTypes.isArrowType typ then
208                    (pps " of "; ppType env ppstrm (BasicTypes.domain typ))                    (pps " of "; ppType env ppstrm (BasicTypes.domain typ))
209                 else ();                 else ();
210                 end_block())                 closeBox())
211            | ppCon (con as T.DATACON{name,typ,...},env) =            | ppCon (con as T.DATACON{name,typ,...},env) =
212                if !internals                if !internals
213                then (begin_block INCONSISTENT 4;                then (openHOVBox 4;
214                      pps "datacon "; ppSym ppstrm name; pps " : ";                      pps "datacon "; ppSym ppstrm name; pps " : ";
215                      ppType env ppstrm typ;                      ppType env ppstrm typ;
216                      end_block())                      closeBox())
217                else ()                else ()
218       in ppCon       in ppCon
219      end      end
220    
221  fun ppStructure ppstrm (str,env,depth) =  fun ppStructure ppstrm (str,env,depth) =
222      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
223       in case str       in case str
224            of M.STR { sign, rlzn as { entities, ... }, ... } =>            of M.STR { sign, rlzn as { entities, ... }, ... } =>
225               (if !internals               (if !internals
226                then (begin_block CONSISTENT 2;                then (openHVBox 2;
227                         pps "STR";                         pps "STR";
228                         nl_indent ppstrm 2;                         nl_indent ppstrm 2;
229                         begin_block CONSISTENT 0;                         openHVBox 0;
230                          pps "sign:";                          pps "sign:";
231                          add_break (1,2);                          break {nsp=1,offset=2};
232                          ppSignature0 ppstrm (sign,env,depth-1,SOME entities);                          ppSignature0 ppstrm (sign,env,depth-1,SOME entities);
233                          add_newline();                          newline();
234                          pps "rlzn:";                          pps "rlzn:";
235                          add_break (1,2);                          break {nsp=1,offset=2};
236                          ppStrEntity ppstrm (rlzn,env,depth-1);                          ppStrEntity ppstrm (rlzn,env,depth-1);
237                         end_block();                         closeBox();
238                        end_block())                        closeBox())
239                  else case sign                  else case sign
240                         of M.SIG { name = SOME sym, ... } =>                         of M.SIG { name = SOME sym, ... } =>
241                            ((if MU.eqSign                            ((if MU.eqSign
# Line 256  Line 259 
259      let fun pr first (sym,spec) =      let fun pr first (sym,spec) =
260             case spec             case spec
261               of M.STRspec{sign,entVar,def,slot} =>               of M.STRspec{sign,entVar,def,slot} =>
262                   (if first then () else add_newline ppstrm;                   (if first then () else newline ppstrm;
263                    begin_block ppstrm CONSISTENT 0;                    openHVBox ppstrm (PP.Rel 0);
264                     add_string ppstrm "structure ";                     pps ppstrm "structure ";
265                     ppSym ppstrm sym; add_string ppstrm " :";                     ppSym ppstrm sym; pps ppstrm " :";
266                     add_break ppstrm (1,2);                     break ppstrm {nsp=1,offset=2};
267                     begin_block ppstrm CONSISTENT 0;                     openHVBox ppstrm (PP.Rel 0);
268                      case entityEnvOp                      case entityEnvOp
269                        of NONE => ppSignature0 ppstrm (sign,env,depth-1,NONE)                        of NONE => ppSignature0 ppstrm (sign,env,depth-1,NONE)
270                         | SOME eenv =>                         | SOME eenv =>
# Line 273  Line 276 
276                                  (sign,env,depth-1,SOME entities)                                  (sign,env,depth-1,SOME entities)
277                            end;                            end;
278                      if !internals                      if !internals
279                      then (add_newline ppstrm;                      then (newline ppstrm;
280                            add_string ppstrm "entVar: ";                            pps ppstrm "entVar: ";
281                            add_string ppstrm (EntPath.entVarToString entVar))                            pps ppstrm (EntPath.entVarToString entVar))
282                      else ();                      else ();
283                     end_block ppstrm;                     closeBox ppstrm;
284                    end_block ppstrm)                    closeBox ppstrm)
285    
286                | M.FCTspec{sign,entVar,slot} =>                | M.FCTspec{sign,entVar,slot} =>
287                   (if first then () else add_newline ppstrm;                   (if first then () else newline ppstrm;
288                    begin_block ppstrm CONSISTENT 0;                    openHVBox ppstrm (PP.Rel 0);
289                     add_string ppstrm "functor ";                     pps ppstrm "functor ";
290                     ppSym ppstrm sym; add_string ppstrm " :";                     ppSym ppstrm sym; pps ppstrm " :";
291                     add_break ppstrm (1,2);                     break ppstrm {nsp=1,offset=2};
292                     begin_block ppstrm CONSISTENT 0;                     openHVBox ppstrm (PP.Rel 0);
293                      ppFunsig ppstrm (sign,env,depth-1);                      ppFunsig ppstrm (sign,env,depth-1);
294                      if !internals                      if !internals
295                      then (add_newline ppstrm;                      then (newline ppstrm;
296                            add_string ppstrm "entVar: ";                            pps ppstrm "entVar: ";
297                            add_string ppstrm (EntPath.entVarToString entVar))                            pps ppstrm (EntPath.entVarToString entVar))
298                      else ();                      else ();
299                     end_block ppstrm;                     closeBox ppstrm;
300                    end_block ppstrm)                    closeBox ppstrm)
301    
302                | M.TYCspec{spec,entVar,repl,scope} =>                | M.TYCspec{spec,entVar,repl,scope} =>
303                   (if first then () else add_newline ppstrm;                   (if first then () else newline ppstrm;
304                    begin_block ppstrm CONSISTENT 0;                    openHVBox ppstrm (PP.Rel 0);
305                     case entityEnvOp                     case entityEnvOp
306                       of NONE => ppTycBind ppstrm (spec,env)                       of NONE =>
307                             if repl then
308                               ppReplBind ppstrm (spec,env)
309                             else ppTycBind ppstrm (spec,env)
310                        | SOME eenv =>                        | SOME eenv =>
311                           (case EE.look(eenv,entVar)                           (case EE.look(eenv,entVar)
312                              of M.TYCent tyc => ppTycBind ppstrm (tyc,env)                              of M.TYCent tyc =>
313                               | M.ERRORent => add_string ppstrm "<ERRORent>"                                   if repl then
314                                       ppReplBind ppstrm (tyc,env)
315                                     else ppTycBind ppstrm (tyc,env)
316                                 | M.ERRORent => pps ppstrm "<ERRORent>"
317                               | _ => bug "ppElements:TYCent");                               | _ => bug "ppElements:TYCent");
318                     if !internals                     if !internals
319                     then (add_newline ppstrm;                     then (newline ppstrm;
320                           add_string ppstrm "entVar: ";                           pps ppstrm "entVar: ";
321                           add_string ppstrm (EntPath.entVarToString entVar);                           pps ppstrm (EntPath.entVarToString entVar);
322                           add_newline ppstrm;                           newline ppstrm;
323                           add_string ppstrm "scope: ";                           pps ppstrm "scope: ";
324                           add_string ppstrm (Int.toString scope))                           pps ppstrm (Int.toString scope))
325                     else ();                     else ();
326                    end_block ppstrm)                    closeBox ppstrm)
327    
328                | M.VALspec{spec=typ,...} =>                | M.VALspec{spec=typ,...} =>
329                   (if first then () else add_newline ppstrm;                   (if first then () else newline ppstrm;
330                    begin_block ppstrm INCONSISTENT 4;                    openHOVBox ppstrm (PP.Rel 4);
331                     add_string ppstrm "val ";                     pps ppstrm "val ";
332                     ppSym ppstrm sym; add_string ppstrm " : ";                     ppSym ppstrm sym; pps ppstrm " : ";
333                     ppType env ppstrm (typ);                     ppType env ppstrm (typ);
334                    end_block ppstrm)                    closeBox ppstrm)
335    
336                | M.CONspec{spec=dcon as T.DATACON{rep=A.EXN _,...}, ...} =>                | M.CONspec{spec=dcon as T.DATACON{rep=A.EXN _,...}, ...} =>
337                   (if first then () else add_newline ppstrm;                   (if first then () else newline ppstrm;
338                    ppConBinding ppstrm (dcon,env))                    ppConBinding ppstrm (dcon,env))
339    
340                | M.CONspec{spec=dcon,...} =>                | M.CONspec{spec=dcon,...} =>
341                   if !internals                   if !internals
342                   then (if first then () else add_newline ppstrm;                   then (if first then () else newline ppstrm;
343                         ppConBinding ppstrm (dcon,env))                         ppConBinding ppstrm (dcon,env))
344                   else () (* ordinary data constructor, don't print *)                   else () (* ordinary data constructor, don't print *)
345    
346       in begin_block ppstrm CONSISTENT 0;       in openHVBox ppstrm (PP.Rel 0);
347          case elements          case elements
348            of nil => ()            of nil => ()
349             | first :: rest => (pr true first; app (pr false) rest);             | first :: rest => (pr true first; app (pr false) rest);
350          end_block ppstrm          closeBox ppstrm
351      end      end
352    
353  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
354      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
355          val env = SE.atop(case entityEnvOp          val env = SE.atop(case entityEnvOp
356                              of NONE => sigToEnv sign                              of NONE => sigToEnv sign
357                               | SOME entEnv => strToEnv(sign,entEnv),                               | SOME entEnv => strToEnv(sign,entEnv),
358                            env)                            env)
359          fun ppConstraints (variety,constraints : M.sharespec list) =          fun ppConstraints (variety,constraints : M.sharespec list) =
360                  (begin_block CONSISTENT 0;                  (openHVBox 0;
361                   ppvseq ppstrm 0 ""                   ppvseq ppstrm 0 ""
362                    (fn ppstrm => fn paths =>                    (fn ppstrm => fn paths =>
363                        (begin_block INCONSISTENT 2;                        (openHOVBox 2;
364                          pps "sharing "; pps variety;                          pps "sharing "; pps variety;
365                          ppSequence ppstrm                          ppSequence ppstrm
366                           {sep=(fn ppstrm =>                           {sep=(fn ppstrm =>
367                                  (pps " ="; add_break (1,0))),                                  (pps " ="; break{nsp=1,offset=0})),
368                            pr=ppSymPath,                            pr=ppSymPath,
369                            style=INCONSISTENT}                            style=INCONSISTENT}
370                           paths;                           paths;
371                         end_block()))                         closeBox()))
372                    constraints;                    constraints;
373                  end_block ())                  closeBox ())
374          val somePrint = ref false          val somePrint = ref false
375       in if depth <= 0       in if depth <= 0
376          then pps "<sig>"          then pps "<sig>"
# Line 369  Line 378 
378          case sign          case sign
379            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
380               if !internals then               if !internals then
381                 (begin_block CONSISTENT 0;                 (openHVBox 0;
382                   pps "SIG:";                   pps "SIG:";
383                   nl_indent ppstrm 2;                   nl_indent ppstrm 2;
384                   begin_block CONSISTENT 0;                   openHVBox 0;
385                    pps "stamp: "; pps (Stamps.toShortString stamp);                    pps "stamp: "; pps (Stamps.toShortString stamp);
386                    add_newline();                    newline();
387                    pps "name: ";                    pps "name: ";
388                    case name                    case name
389                      of NONE => pps "ANONYMOUS"                      of NONE => pps "ANONYMOUS"
390                       | SOME p => (pps "NAMED "; ppSym ppstrm p);                       | SOME p => (pps "NAMED "; ppSym ppstrm p);
391                    case elements                    case elements
392                      of nil => ()                      of nil => ()
393                       | _ => (add_newline(); pps "elements:";                       | _ => (newline(); pps "elements:";
394                               nl_indent ppstrm 2;                               nl_indent ppstrm 2;
395                               ppElements (env,depth,entityEnvOp) ppstrm elements);                               ppElements (env,depth,entityEnvOp) ppstrm elements);
396                    case strsharing                    case strsharing
397                      of nil => ()                      of nil => ()
398                       | _ => (add_newline(); pps "strsharing:";                       | _ => (newline(); pps "strsharing:";
399                               nl_indent ppstrm 2;                               nl_indent ppstrm 2;
400                               ppConstraints("",strsharing));                               ppConstraints("",strsharing));
401                    case typsharing                    case typsharing
402                      of nil => ()                      of nil => ()
403                       | _ => (add_newline(); pps "tycsharing:";                       | _ => (newline(); pps "tycsharing:";
404                               nl_indent ppstrm 2;                               nl_indent ppstrm 2;
405                               ppConstraints("type ",typsharing));                               ppConstraints("type ",typsharing));
406                   end_block();                   closeBox();
407                  end_block())                  closeBox())
408                else (* not !internals *)                else (* not !internals *)
409                  (begin_block CONSISTENT 0;                  (openHVBox 0;
410                    pps "sig";                    pps "sig";
411                    add_break (1,2);                    break{nsp=1,offset=2};
412                    begin_block CONSISTENT 0;                    openHVBox 0;
413                     case elements                     case elements
414                       of nil => ()                       of nil => ()
415                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;
416                                somePrint := true);                                somePrint := true);
417                     case strsharing                     case strsharing
418                       of nil => ()                       of nil => ()
419                        | _ => (if !somePrint then add_newline() else ();                        | _ => (if !somePrint then newline() else ();
420                                ppConstraints("",strsharing);                                ppConstraints("",strsharing);
421                                somePrint := true);                                somePrint := true);
422                     case typsharing                     case typsharing
423                       of nil => ()                       of nil => ()
424                        | _ => (if !somePrint then add_newline() else ();                        | _ => (if !somePrint then newline() else ();
425                                ppConstraints("type ",typsharing);                                ppConstraints("type ",typsharing);
426                                somePrint := true);                                somePrint := true);
427                    end_block();                    closeBox();
428                    if !somePrint then add_break(1,0) else ();                    if !somePrint then break{nsp=1,offset=0} else ();
429                    pps "end";                    pps "end";
430                   end_block())                   closeBox())
431             | M.ERRORsig => pps "<error sig>"             | M.ERRORsig => pps "<error sig>"
432      end      end
433    
434  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
435      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
436          fun trueBodySig (orig as M.SIG { elements =          fun trueBodySig (orig as M.SIG { elements =
437                                           [(sym, M.STRspec { sign, ... })],                                           [(sym, M.STRspec { sign, ... })],
438                                           ... }) =                                           ... }) =
# Line 433  Line 442 
442          else case sign          else case sign
443                 of M.FSIG {paramsig,paramvar,paramsym,bodysig, ...} =>                 of M.FSIG {paramsig,paramvar,paramsym,bodysig, ...} =>
444                     if !internals                     if !internals
445                     then (begin_block CONSISTENT 0;                     then (openHVBox 0;
446                            pps "FSIG:";                            pps "FSIG:";
447                            nl_indent ppstrm 2;                            nl_indent ppstrm 2;
448                            begin_block CONSISTENT 0;                            openHVBox 0;
449                             pps "psig: ";                             pps "psig: ";
450                             ppSignature0 ppstrm (paramsig,env,depth-1,NONE);                             ppSignature0 ppstrm (paramsig,env,depth-1,NONE);
451                             add_newline();                             newline();
452                             pps "pvar: ";                             pps "pvar: ";
453                             pps (EntPath.entVarToString paramvar);                             pps (EntPath.entVarToString paramvar);
454                             add_newline();                             newline();
455                             pps "psym: ";                             pps "psym: ";
456                             (case paramsym                             (case paramsym
457                                of NONE => pps "<anonymous>"                                of NONE => pps "<anonymous>"
458                                 | SOME sym => ppSym ppstrm sym);                                 | SOME sym => ppSym ppstrm sym);
459                             add_newline();                             newline();
460                             pps "bsig: ";                             pps "bsig: ";
461                             ppSignature0 ppstrm (bodysig,env,depth-1,NONE);                             ppSignature0 ppstrm (bodysig,env,depth-1,NONE);
462                            end_block();                            closeBox();
463                           end_block())                           closeBox())
464                     else (begin_block CONSISTENT 0;                     else (openHVBox 0;
465                            pps "(";                            pps "(";
466                            case paramsym                            case paramsym
467                              of SOME x => pps (S.name x)                              of SOME x => pps (S.name x)
# Line 460  Line 469 
469                            pps ": ";                            pps ": ";
470                            ppSignature0 ppstrm (paramsig,env,depth-1,NONE);                            ppSignature0 ppstrm (paramsig,env,depth-1,NONE);
471                            pps ") :";                            pps ") :";
472                            add_break(1,0);                            break{nsp=1,offset=0};
473                            ppSignature0 ppstrm                            ppSignature0 ppstrm
474                              (trueBodySig bodysig,env,depth-1,NONE);                              (trueBodySig bodysig,env,depth-1,NONE);
475                           end_block())                           closeBox())
476                  | M.ERRORfsig => pps "<error fsig>"                  | M.ERRORfsig => pps "<error fsig>"
477      end      end
478    
479    
480  and ppStrEntity ppstrm (e,env,depth) =  and ppStrEntity ppstrm (e,env,depth) =
481      let val {stamp,entities,properties,rpath,stub} = e      let val {stamp,entities,properties,rpath,stub} = e
482          val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
483       in if depth <= 1       in if depth <= 1
484          then pps "<structure entity>"          then pps "<structure entity>"
485          else (begin_block CONSISTENT 0;          else (openHVBox 0;
486                 pps "strEntity:";                 pps "strEntity:";
487                 nl_indent ppstrm 2;                 nl_indent ppstrm 2;
488                 begin_block CONSISTENT 0;                 openHVBox 0;
489                  pps "rpath: ";                  pps "rpath: ";
490                  pps (IP.toString rpath);                  pps (IP.toString rpath);
491                  add_newline();                  newline();
492                  pps "stamp: ";                  pps "stamp: ";
493                  pps (Stamps.toShortString stamp);                  pps (Stamps.toShortString stamp);
494                  add_newline();                  newline();
495                  pps "entities:";                  pps "entities:";
496                  nl_indent ppstrm 2;                  nl_indent ppstrm 2;
497                  ppEntityEnv ppstrm (entities,env,depth-1);                  ppEntityEnv ppstrm (entities,env,depth-1);
498                  add_newline();                  newline();
499                  pps "lambdaty:";                  pps "lambdaty:";
500                  nl_indent ppstrm 2;                  nl_indent ppstrm 2;
501                  ppLty ppstrm ( (* ModulePropLists.strEntityLty e,depth-1 *));                  ppLty ppstrm ( (* ModulePropLists.strEntityLty e,depth-1 *));
502                 end_block ();                 closeBox ();
503                end_block ())                closeBox ())
504      end      end
505    
506  and ppFctEntity ppstrm (e, env, depth) =  and ppFctEntity ppstrm (e, env, depth) =
507      let val {stamp,closure,properties,tycpath,rpath,stub} = e      let val {stamp,closure,properties,tycpath,rpath,stub} = e
508          val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm          val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
509      in if depth <= 1      in if depth <= 1
510          then pps "<functor entity>"          then pps "<functor entity>"
511          else (begin_block CONSISTENT 0;          else (openHVBox 0;
512                 pps "fctEntity:";                 pps "fctEntity:";
513                 nl_indent ppstrm 2;                 nl_indent ppstrm 2;
514                 begin_block CONSISTENT 0;                 openHVBox 0;
515                  pps "rpath: ";                  pps "rpath: ";
516                  pps (IP.toString rpath);                  pps (IP.toString rpath);
517                  add_newline();                  newline();
518                  pps "stamp: ";                  pps "stamp: ";
519                  pps (Stamps.toShortString stamp);                  pps (Stamps.toShortString stamp);
520                  add_newline();                  newline();
521                  pps "closure:";                  pps "closure:";
522                  add_break (1,2);                  break{nsp=1,offset=2};
523                  ppClosure ppstrm (closure,depth-1);                  ppClosure ppstrm (closure,depth-1);
524                  add_newline();                  newline();
525                  pps "lambdaty:";                  pps "lambdaty:";
526                  add_break (1,2);                  break{nsp=1,offset=2};
527                  ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );                  ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );
528                  pps "tycpath:";                  pps "tycpath:";
529                  add_break (1,2);                  break{nsp=1,offset=2};
530                  pps "--printing of tycpath not implemented yet--";                  pps "--printing of tycpath not implemented yet--";
531                 end_block ();                 closeBox ();
532                end_block ())                closeBox ())
533      end      end
534    
535  and ppFunctor ppstrm =  and ppFunctor ppstrm =
536      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
537          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =
538                  if depth <= 1                  if depth <= 1
539                  then pps "<functor>"                  then pps "<functor>"
540                  else (begin_block CONSISTENT 0;                  else (openHVBox 0;
541                        pps "sign:";                        pps "sign:";
542                        nl_indent ppstrm 2;                        nl_indent ppstrm 2;
543                        ppFunsig ppstrm (sign,env,depth-1);                        ppFunsig ppstrm (sign,env,depth-1);
544                        add_newline();                        newline();
545                        pps "rlzn:";                        pps "rlzn:";
546                        nl_indent ppstrm 2;                        nl_indent ppstrm 2;
547                        ppFctEntity ppstrm (rlzn,env,depth-1);                        ppFctEntity ppstrm (rlzn,env,depth-1);
548                        end_block ())                        closeBox ())
549            | ppF (M.ERRORfct,_,_) = pps "<error functor>"            | ppF (M.ERRORfct,_,_) = pps "<error functor>"
550       in ppF       in ppF
551      end      end
552    
553  and ppTycBind ppstrm (tyc,env) =  and ppTycBind ppstrm (tyc,env) =
554      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
555          fun visibleDcons(tyc,dcons) =          fun visibleDcons(tyc,dcons) =
556              let fun checkCON(V.CON c) = c              let fun checkCON(V.CON c) = c
557                    | checkCON _ = raise SE.Unbound                    | checkCON _ = raise SE.Unbound
# Line 567  Line 576 
576                                 (* something's weird *)                                 (* something's weird *)
577                                   let val old_internals = !internals                                   let val old_internals = !internals
578                                    in internals := true;                                    in internals := true;
579                                       begin_block CONSISTENT 0;                                       openHVBox 0;
580                                        pps "ppTycBind failure: ";                                        pps "ppTycBind failure: ";
581                                        add_newline();                                        newline();
582                                        ppTycon env ppstrm tyc;                                        ppTycon env ppstrm tyc;
583                                        add_newline();                                        newline();
584                                        ppTycon env ppstrm d_found;                                        ppTycon env ppstrm d_found;
585                                        add_newline();                                        newline();
586                                       end_block();                                       closeBox();
587                                       internals := old_internals;                                       internals := old_internals;
588                                       find rest                                       find rest
589                                   end                                   end
# Line 593  Line 602 
602                   else ()                   else ()
603               end)               end)
604       in if !internals       in if !internals
605          then (begin_block CONSISTENT 0;          then (openHVBox 0;
606                 pps "type "; ppTycon env ppstrm tyc;                 pps "type "; ppTycon env ppstrm tyc;
607                end_block())                closeBox())
608          else          else
609              case tyc of              case tyc of
610                  T.GENtyc { path, arity, eq, kind, ... } =>                  T.GENtyc { path, arity, eq, kind, ... } =>
611                  (case (!eq, kind) of                  (case (!eq, kind) of
612                       (T.ABS, _) =>                       (T.ABS, _) =>
613                       (* abstype *)                       (* abstype *)
614                       (begin_block CONSISTENT 0;                       (openHVBox 0;
615                        pps "type";                        pps "type";
616                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
617                        pps " ";                        pps " ";
618                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path);
619                        end_block())                        closeBox())
620                     | (_, T.DATATYPE{index,family={members,...},...}) =>                     | (_, T.DATATYPE{index,family={members,...},...}) =>
621                       (* ordinary datatype *)                       (* ordinary datatype *)
622                       let val {dcons,...} = Vector.sub(members,index)                       let val {dcons,...} = Vector.sub(members,index)
623                           val visdcons = visibleDcons(tyc,dcons)                           val visdcons = visibleDcons(tyc,dcons)
624                           val incomplete = length visdcons < length dcons                           val incomplete = length visdcons < length dcons
625                       in                       in
626                           begin_block CONSISTENT 0;                           openHVBox 0;
627                           pps "datatype";                           pps "datatype";
628                           ppFormals ppstrm arity;                           ppFormals ppstrm arity;
629                           pps " ";                           pps " ";
# Line 622  Line 631 
631                           case visdcons                           case visdcons
632                             of nil => pps " = ..."                             of nil => pps " = ..."
633                              | first :: rest =>                              | first :: rest =>
634                                 (add_break(1,2);                                 (break{nsp=1,offset=2};
635                                  begin_block CONSISTENT 0;                                  openHVBox 0;
636                                   pps "= "; ppDcon first;                                   pps "= "; ppDcon first;
637                                   app (fn d => (add_break(1,0); pps "| "; ppDcon d))                                   app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))
638                                       rest;                                       rest;
639                                   if incomplete                                   if incomplete
640                                       then (add_break(1,0); pps "... ")                                       then (break{nsp=1,offset=0}; pps "... ")
641                                   else ();                                   else ();
642                                  end_block());                                  closeBox());
643                          end_block()                          closeBox()
644                      end                      end
645                     | _ =>                     | _ =>
646                       (begin_block CONSISTENT 0;                       (openHVBox 0;
647                        if EqTypes.isEqTycon tyc                        if EqTypes.isEqTycon tyc
648                        then pps "eqtype"                        then pps "eqtype"
649                        else pps "type";                        else pps "type";
650                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
651                        pps " ";                        pps " ";
652                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path);
653                        end_block()))                        closeBox()))
654                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>
655                  (begin_block INCONSISTENT 2;                  (openHOVBox 2;
656                   pps "type";                   pps "type";
657                   ppFormals ppstrm arity;                   ppFormals ppstrm arity;
658                   add_break (1,0);                   break{nsp=1,offset=0};
659                   ppSym ppstrm (InvPath.last path);                   ppSym ppstrm (InvPath.last path);
660                   pps " =";                   pps " =";
661                   add_break (1,0);                   break{nsp=1,offset=0};
662                   ppType env ppstrm body;                   ppType env ppstrm body;
663                   end_block ())                   closeBox ())
664                | tycon =>                | tycon =>
665                  (pps "strange tycon: ";                  (pps "strange tycon: ";
666                   ppTycon env ppstrm tycon)                   ppTycon env ppstrm tycon)
667      end (* ppTycBind *)      end (* ppTycBind *)
668    
669    and ppReplBind ppstrm
670         (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =
671        let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
672         in openHOVBox 2;
673            pps "datatype"; break{nsp=1,offset=0};
674            ppSym ppstrm (IP.last path);
675            pps " ="; break{nsp=1,offset=0};
676            pps "datatype"; break{nsp=1,offset=0};
677            ppTycon env ppstrm rightTyc;
678            closeBox ()
679        end
680      | ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"
681    
682  and ppEntity ppstrm (entity,env,depth) =  and ppEntity ppstrm (entity,env,depth) =
683      case entity      case entity
684        of M.TYCent tycon => ppTycon env ppstrm tycon        of M.TYCent tycon => ppTycon env ppstrm tycon
685         | M.STRent strEntity => ppStrEntity ppstrm (strEntity,env,depth-1)         | M.STRent strEntity => ppStrEntity ppstrm (strEntity,env,depth-1)
686         | M.FCTent fctEntity => ppFctEntity ppstrm (fctEntity,env,depth-1)         | M.FCTent fctEntity => ppFctEntity ppstrm (fctEntity,env,depth-1)
687         | M.ERRORent => add_string ppstrm "ERRORent"         | M.ERRORent => pps ppstrm "ERRORent"
688    
689  and ppEntityEnv ppstrm (entEnv,env,depth) =  and ppEntityEnv ppstrm (entEnv,env,depth) =
690      if depth <= 1      if depth <= 1
691      then add_string ppstrm "<entityEnv>"      then pps ppstrm "<entityEnv>"
692      else (ppvseq ppstrm 2 ""      else (ppvseq ppstrm 2 ""
693                (fn ppstrm => fn (entVar,entity) =>                (fn ppstrm => fn (entVar,entity) =>
694                  let val {begin_block,end_block,pps,add_break,add_newline} =                  let val {openHVBox,openHOVBox,closeBox,pps,break,newline} =
695                           en_pp ppstrm                           en_pp ppstrm
696                   in begin_block CONSISTENT 2;                   in openHVBox 2;
697                       pps (EntPath.entVarToString entVar);                       pps (EntPath.entVarToString entVar);
698                       pps ":";                       pps ":";
699                       nl_indent ppstrm 2;                       nl_indent ppstrm 2;
700                       ppEntity ppstrm (entity,env,depth-1);                       ppEntity ppstrm (entity,env,depth-1);
701                       add_newline();                       newline();
702                      end_block()                      closeBox()
703                  end)                  end)
704            (EE.toList entEnv))            (EE.toList entEnv))
705    
706  and ppEntDec ppstrm (entDec,depth) =  and ppEntDec ppstrm (entDec,depth) =
707      if depth <= 0 then add_string ppstrm "<entDec>"      if depth <= 0 then pps ppstrm "<entDec>"
708      else case entDec      else case entDec
709            of M.TYCdec(entVar,tycExp) =>            of M.TYCdec(entVar,tycExp) =>
710                (add_string ppstrm "ED.T: ";                (pps ppstrm "ED.T: ";
711                 ppEntVar ppstrm entVar; add_break ppstrm (1,1);                 ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
712                 ppTycExp ppstrm (tycExp,depth-1))                 ppTycExp ppstrm (tycExp,depth-1))
713             | M.STRdec(entVar,strExp,sym) =>             | M.STRdec(entVar,strExp,sym) =>
714                (add_string ppstrm "ED.S: ";                (pps ppstrm "ED.S: ";
715                 ppEntVar ppstrm entVar; add_break ppstrm (1,1);                 ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
716                 ppStrExp ppstrm (strExp,depth-1); add_break ppstrm (1,1);                 ppStrExp ppstrm (strExp,depth-1); break ppstrm {nsp=1,offset=1};
717                 ppSym ppstrm sym)                 ppSym ppstrm sym)
718             | M.FCTdec(entVar,fctExp) =>             | M.FCTdec(entVar,fctExp) =>
719                (add_string ppstrm "ED.F: ";                (pps ppstrm "ED.F: ";
720                 ppEntVar ppstrm entVar; add_break ppstrm (1,1);                 ppEntVar ppstrm entVar; break ppstrm {nsp=1,offset=1};
721                 ppFctExp ppstrm (fctExp,depth-1))                 ppFctExp ppstrm (fctExp,depth-1))
722             | M.SEQdec entityDecs =>             | M.SEQdec entityDecs =>
723                ppvseq ppstrm 0 ""                ppvseq ppstrm 0 ""
724                  (fn ppstrm => fn entDec => ppEntDec ppstrm (entDec,depth))                  (fn ppstrm => fn entDec => ppEntDec ppstrm (entDec,depth))
725                  entityDecs                  entityDecs
726             | M.LOCALdec(entityDecL,entityDecB) => add_string ppstrm "ED.L:"             | M.LOCALdec(entityDecL,entityDecB) => pps ppstrm "ED.L:"
727             | M.ERRORdec => add_string ppstrm "ED.ER:"             | M.ERRORdec => pps ppstrm "ED.ER:"
728             | M.EMPTYdec => add_string ppstrm "ED.EM:"             | M.EMPTYdec => pps ppstrm "ED.EM:"
729    
730  and ppStrExp ppstrm (strExp,depth) =  and ppStrExp ppstrm (strExp,depth) =
731      if depth <= 0 then add_string ppstrm "<strExp>" else      if depth <= 0 then pps ppstrm "<strExp>" else
732      case strExp      case strExp
733        of M.VARstr ep =>        of M.VARstr ep =>
734            (add_string ppstrm "SE.V:"; add_break ppstrm (1,1);            (pps ppstrm "SE.V:"; break ppstrm {nsp=1,offset=1};
735             ppEntPath ppstrm ep)             ppEntPath ppstrm ep)
736         | M.CONSTstr { stamp, rpath, ... } =>         | M.CONSTstr { stamp, rpath, ... } =>
737           (add_string ppstrm "SE.C:"; add_break ppstrm (1,1);           (pps ppstrm "SE.C:"; break ppstrm {nsp=1,offset=1};
738            ppInvPath ppstrm rpath)            ppInvPath ppstrm rpath)
739         | M.STRUCTURE{stamp,entDec} =>         | M.STRUCTURE{stamp,entDec} =>
740            (add_string ppstrm "SE.S:"; add_break ppstrm (1,1);            (pps ppstrm "SE.S:"; break ppstrm {nsp=1,offset=1};
741             ppEntDec ppstrm (entDec,depth-1))             ppEntDec ppstrm (entDec,depth-1))
742         | M.APPLY(fctExp,strExp) =>         | M.APPLY(fctExp,strExp) =>
743            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
744              add_string ppstrm "SE.AP:"; add_break ppstrm (1,1);              pps ppstrm "SE.AP:"; break ppstrm {nsp=1,offset=1};
745              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
746               add_string ppstrm "fct:"; ppFctExp ppstrm (fctExp, depth -1);               pps ppstrm "fct:"; ppFctExp ppstrm (fctExp, depth -1);
747               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
748               add_string ppstrm "arg:"; ppStrExp ppstrm (strExp, depth -1);               pps ppstrm "arg:"; ppStrExp ppstrm (strExp, depth -1);
749              end_block ppstrm;              closeBox ppstrm;
750             end_block ppstrm)             closeBox ppstrm)
751         | M.LETstr(entDec,strExp) =>         | M.LETstr(entDec,strExp) =>
752            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
753             add_string ppstrm "SE.L:"; add_break ppstrm (1,1);             pps ppstrm "SE.L:"; break ppstrm {nsp=1,offset=1};
754             begin_block ppstrm CONSISTENT 0;             openHVBox ppstrm (PP.Rel 0);
755             add_string ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);             pps ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);
756             add_break ppstrm (1,0);             break ppstrm {nsp=1,offset=0};
757             add_string ppstrm "in:"; ppStrExp ppstrm (strExp, depth -1);             pps ppstrm "in:"; ppStrExp ppstrm (strExp, depth -1);
758             end_block ppstrm;             closeBox ppstrm;
759             end_block ppstrm)             closeBox ppstrm)
760         | M.ABSstr(sign,strExp) =>         | M.ABSstr(sign,strExp) =>
761            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
762             add_string ppstrm "SE.AB:"; add_break ppstrm (1,1);             pps ppstrm "SE.AB:"; break ppstrm {nsp=1,offset=1};
763              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
764               add_string ppstrm "sign: <omitted>";               pps ppstrm "sign: <omitted>";
765               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
766               add_string ppstrm "sexp:"; ppStrExp ppstrm (strExp, depth -1);               pps ppstrm "sexp:"; ppStrExp ppstrm (strExp, depth -1);
767              end_block ppstrm;              closeBox ppstrm;
768             end_block ppstrm)             closeBox ppstrm)
769         | M.CONSTRAINstr{boundvar,raw,coercion} =>         | M.CONSTRAINstr{boundvar,raw,coercion} =>
770            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
771             add_string ppstrm "SE.CO:"; add_break ppstrm (1,1);             pps ppstrm "SE.CO:"; break ppstrm {nsp=1,offset=1};
772              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
773               ppEntVar ppstrm boundvar; add_break ppstrm (1,1);               ppEntVar ppstrm boundvar; break ppstrm {nsp=1,offset=1};
774               add_string ppstrm "src:"; ppStrExp ppstrm (raw, depth -1);               pps ppstrm "src:"; ppStrExp ppstrm (raw, depth -1);
775               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
776               add_string ppstrm "tgt:"; ppStrExp ppstrm (coercion, depth -1);               pps ppstrm "tgt:"; ppStrExp ppstrm (coercion, depth -1);
777              end_block ppstrm;              closeBox ppstrm;
778             end_block ppstrm)             closeBox ppstrm)
779         | M.FORMstr(sign) => add_string ppstrm "SE.FM:"         | M.FORMstr(sign) => pps ppstrm "SE.FM:"
780    
781  and ppFctExp ppstrm (fctExp,depth) =  and ppFctExp ppstrm (fctExp,depth) =
782      if depth <= 0 then add_string ppstrm "<fctExp>" else      if depth <= 0 then pps ppstrm "<fctExp>" else
783      case fctExp      case fctExp
784        of M.VARfct ep =>        of M.VARfct ep =>
785            (add_string ppstrm "FE.V:"; ppEntPath ppstrm ep)            (pps ppstrm "FE.V:"; ppEntPath ppstrm ep)
786         | M.CONSTfct { rpath, ... } =>         | M.CONSTfct { rpath, ... } =>
787            (add_string ppstrm "FE.C:"; ppInvPath ppstrm rpath)            (pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)
788         | M.LAMBDA_TP {param, body, ...} =>         | M.LAMBDA_TP {param, body, ...} =>
789            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
790              add_string ppstrm "FE.LP:"; add_break ppstrm (1,1);              pps ppstrm "FE.LP:"; break ppstrm {nsp=1,offset=1};
791              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
792               add_string ppstrm "par:"; ppEntVar ppstrm param;               pps ppstrm "par:"; ppEntVar ppstrm param;
793               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
794               add_string ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
795              end_block ppstrm;              closeBox ppstrm;
796             end_block ppstrm)             closeBox ppstrm)
797         | M.LAMBDA {param, body} =>         | M.LAMBDA {param, body} =>
798            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
799              add_string ppstrm "FE.L:"; add_break ppstrm (1,1);              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};
800              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
801               add_string ppstrm "par:"; ppEntVar ppstrm param;               pps ppstrm "par:"; ppEntVar ppstrm param;
802               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
803               add_string ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
804              end_block ppstrm;              closeBox ppstrm;
805             end_block ppstrm)             closeBox ppstrm)
806         | M.LETfct (entDec,fctExp) =>         | M.LETfct (entDec,fctExp) =>
807            (begin_block ppstrm CONSISTENT 0;            (openHVBox ppstrm (PP.Rel 0);
808              add_string ppstrm "FE.LT:"; add_break ppstrm (1,1);              pps ppstrm "FE.LT:"; break ppstrm {nsp=1,offset=1};
809              begin_block ppstrm CONSISTENT 0;              openHVBox ppstrm (PP.Rel 0);
810               add_string ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);               pps ppstrm "let:"; ppEntDec ppstrm (entDec,depth-1);
811               add_break ppstrm (1,0);               break ppstrm {nsp=1,offset=0};
812               add_string ppstrm "in:"; ppFctExp ppstrm (fctExp, depth -1);               pps ppstrm "in:"; ppFctExp ppstrm (fctExp, depth -1);
813              end_block ppstrm;              closeBox ppstrm;
814             end_block ppstrm)             closeBox ppstrm)
815    
816  (*  (*
817  and ppBodyExp ppstrm (bodyExp,depth) =  and ppBodyExp ppstrm (bodyExp,depth) =
818      if depth <= 0 then add_string ppstrm "<bodyExp>" else      if depth <= 0 then pps ppstrm "<bodyExp>" else
819      case bodyExp      case bodyExp
820        of M.FLEX sign => add_string ppstrm "BE.F:"        of M.FLEX sign => pps ppstrm "BE.F:"
821         | M.OPAQ (sign,strExp) =>         | M.OPAQ (sign,strExp) =>
822             (begin_block ppstrm CONSISTENT 0;             (openHVBox ppstrm (PP.Rel 0);
823               add_string ppstrm "BE.O:"; add_break ppstrm (1,1);               pps ppstrm "BE.O:"; break ppstrm {nsp=1,offset=1};
824               ppStrExp ppstrm (strExp,depth-1);               ppStrExp ppstrm (strExp,depth-1);
825              end_block ppstrm)              closeBox ppstrm)
826         | M.TNSP (sign,strExp) =>         | M.TNSP (sign,strExp) =>
827             (begin_block ppstrm CONSISTENT 0;             (openHVBox ppstrm (PP.Rel 0);
828               add_string ppstrm "BE.T:"; add_break ppstrm (1,1);               pps ppstrm "BE.T:"; break ppstrm {nsp=1,offset=1};
829               ppStrExp ppstrm (strExp,depth-1);               ppStrExp ppstrm (strExp,depth-1);
830              end_block ppstrm)              closeBox ppstrm)
831    
832  *)  *)
833    
834  and ppClosure ppstrm (M.CLOSURE{param,body,env},depth) =  and ppClosure ppstrm (M.CLOSURE{param,body,env},depth) =
835      let val {begin_block,end_block,pps,add_newline,add_break,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,newline,break,...} = en_pp ppstrm
836       in begin_block CONSISTENT 0;       in openHVBox 0;
837           pps "CL:"; add_break (1,1);           pps "CL:"; break{nsp=1,offset=1};
838            begin_block CONSISTENT 0;            openHVBox 0;
839             pps "param: "; ppEntVar ppstrm param; add_newline();             pps "param: "; ppEntVar ppstrm param; newline();
840             pps "body: "; ppStrExp ppstrm (body,depth-1); add_newline();             pps "body: "; ppStrExp ppstrm (body,depth-1); newline();
841             pps "env: "; ppEntityEnv ppstrm (env,SE.empty,depth-1);             pps "env: "; ppEntityEnv ppstrm (env,SE.empty,depth-1);
842            end_block();            closeBox();
843          end_block()          closeBox()
844      end      end
845    
846  (* assumes no newline is needed before pping *)  (* assumes no newline is needed before pping *)
# Line 828  Line 850 
850         | B.CONbind con => ppConBinding ppstrm (con,env)         | B.CONbind con => ppConBinding ppstrm (con,env)
851         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)
852         | B.SIGbind sign =>         | B.SIGbind sign =>
853            let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm            let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
854             in begin_block CONSISTENT 0;             in openHVBox 0;
855                 pps "signature "; ppSym ppstrm name; pps " =";                 pps "signature "; ppSym ppstrm name; pps " =";
856                 add_break(1,2);                 break{nsp=1,offset=2};
857                 ppSignature0 ppstrm (sign,env,depth,NONE);                 ppSignature0 ppstrm (sign,env,depth,NONE);
858                end_block()                closeBox()
859            end            end
860         | B.FSGbind fs =>         | B.FSGbind fs =>
861            let val {begin_block,end_block,pps,...} = en_pp ppstrm            let val {openHVBox,openHOVBox,closeBox,pps,...} = en_pp ppstrm
862             in begin_block CONSISTENT 2;             in openHVBox 2;
863                 pps "funsig "; ppSym ppstrm name;                 pps "funsig "; ppSym ppstrm name;
864                 ppFunsig ppstrm (fs,env,depth);                 ppFunsig ppstrm (fs,env,depth);
865                end_block()                closeBox()
866            end            end
867         | B.STRbind str =>         | B.STRbind str =>
868            let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm            let val {openHVBox, openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
869             in begin_block CONSISTENT 0;             in openHVBox 0;
870                 pps "structure "; ppSym ppstrm name; pps " :";                 pps "structure "; ppSym ppstrm name; pps " :";
871                 add_break(1,2);                 break{nsp=1,offset=2};
872                 ppStructure ppstrm (str,env,depth);                 ppStructure ppstrm (str,env,depth);
873                end_block()                closeBox()
874            end            end
875         | B.FCTbind fct =>         | B.FCTbind fct =>
876            let val {begin_block,end_block,pps,...} = en_pp ppstrm            let val {openHVBox,openHOVBox,closeBox,pps,...} = en_pp ppstrm
877             in begin_block CONSISTENT 0;             in openHVBox 0;
878                 pps "functor ";                 pps "functor ";
879                 ppSym ppstrm name;                 ppSym ppstrm name;
880                 pps " : <sig>";  (* DBM -- should print the signature *)                 pps " : <sig>";  (* DBM -- should print the signature *)
881                end_block()                closeBox()
882            end            end
883         | B.FIXbind fixity =>         | B.FIXbind fixity =>
884            (pps ppstrm (Fixity.fixityToString fixity); ppSym ppstrm name)            (pps ppstrm (Fixity.fixityToString fixity); ppSym ppstrm name)
# Line 877  Line 899 
899                                  [] l                                  [] l
900          val pp_env = StaticEnv.atop(env,topenv)          val pp_env = StaticEnv.atop(env,topenv)
901       in ppSequence ppstrm       in ppSequence ppstrm
902            {sep=add_newline,            {sep=newline,
903             pr=(fn ppstrm => fn (name,binding) =>             pr=(fn ppstrm => fn (name,binding) =>
904                    ppBinding ppstrm (name,binding,pp_env,depth)),                    ppBinding ppstrm (name,binding,pp_env,depth)),
905             style=CONSISTENT}             style=CONSISTENT}
# Line 885  Line 907 
907      end      end
908    
909  fun ppOpen ppstrm (path,str,env,depth) =  fun ppOpen ppstrm (path,str,env,depth) =
910      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
911       in begin_block CONSISTENT 0;       in openHVBox 0;
912           begin_block CONSISTENT 2;           openHVBox 2;
913            add_string ppstrm "opening ";            pps "opening ";
914            ppSymPath ppstrm path;            ppSymPath ppstrm path;
915            if depth < 1 then ()            if depth < 1 then ()
916            else (case str            else (case str
# Line 896  Line 918 
918                       (case sign                       (case sign
919                           of M.SIG {elements = [],...} => ()                           of M.SIG {elements = [],...} => ()
920                            | M.SIG {elements,...} =>                            | M.SIG {elements,...} =>
921                              (add_newline ();                              (newline ();
922                               begin_block CONSISTENT 0;                               openHVBox 0;
923                               ppElements (SE.atop(sigToEnv sign, env),                               ppElements (SE.atop(sigToEnv sign, env),
924                                           depth,SOME entities)                                           depth,SOME entities)
925                                          ppstrm elements;                                          ppstrm elements;
926                               end_block ())                               closeBox ())
927                            | M.ERRORsig => ())                            | M.ERRORsig => ())
928                     | M.ERRORstr => ()                     | M.ERRORstr => ()
929                     | M.STRSIG _ => bug "ppOpen");                     | M.STRSIG _ => bug "ppOpen");
930           end_block ();           closeBox ();
931           add_newline();           newline();
932          end_block ()          closeBox ()
933      end      end
934    
935  fun ppSignature ppstrm (sign,env,depth) =  fun ppSignature ppstrm (sign,env,depth) =

Legend:
Removed from v.1343  
changed lines
  Added in v.1344

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