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

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

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

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

Legend:
Removed from v.902  
changed lines
  Added in v.2571

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