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/pptype.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Elaborator/print/pptype.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 1991 by AT&T Bell Laboratories *)  (* Copyright 1991 by AT&T Bell Laboratories *)
2    (* Copyright 2003 by The SML/NJ Fellowship *)
3    (* pptype.sml *)
4    
5    (* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6    
7  signature PPTYPE =  signature PPTYPE =
8  sig  sig
9    val typeFormals : int -> string list    val typeFormals : int -> string list
10    val tyvarPrintname : Types.tyvar -> string    val tyvarPrintname : Types.tyvar -> string
11    val ppTycon : StaticEnv.staticEnv -> PrettyPrint.ppstream    val ppTycon : StaticEnv.staticEnv -> PrettyPrint.stream
12                  -> Types.tycon -> unit                  -> Types.tycon -> unit
13    val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.ppstream    val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.stream
14                  -> Types.tyfun -> unit                  -> Types.tyfun -> unit
15    val ppType  : StaticEnv.staticEnv -> PrettyPrint.ppstream    val ppType  : StaticEnv.staticEnv -> PrettyPrint.stream
16                  -> Types.ty -> unit                  -> Types.ty -> unit
17    val ppDconDomain : (Types.dtmember vector * Types.tycon list)    val ppDconDomain : (Types.dtmember vector * Types.tycon list)
18                       -> StaticEnv.staticEnv                       -> StaticEnv.staticEnv
19                       -> PrettyPrint.ppstream -> Types.ty -> unit                       -> PrettyPrint.stream -> Types.ty -> unit
20    val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.ppstream    val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.stream
21                  -> Types.tycon -> unit                  -> Types.tycon -> unit
22    val resetPPType : unit -> unit    val resetPPType : unit -> unit
23    val ppFormals : PrettyPrint.ppstream -> int -> unit    val ppFormals : PrettyPrint.stream -> int -> unit
24    
25    val debugging : bool ref    val debugging : bool ref
26    val unalias : bool ref    val unalias : bool ref
# Line 40  Line 44 
44  val unalias = ref true  val unalias = ref true
45    
46  fun bug s = ErrorMsg.impossible ("PPType: " ^ s)  fun bug s = ErrorMsg.impossible ("PPType: " ^ s)
47  val pps = PP.add_string  val pps = PP.string
48    
49  fun C f x y = f y x  fun C f x y = f y x
50    
# Line 201  Line 205 
205      end      end
206    
207  fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =  fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
208      PP.add_string ppstream (SymPath.toString (SymPath.SPATH(rev path)))      PP.string ppstream (SymPath.toString (SymPath.SPATH(rev path)))
209    
210  fun ppTycon1 env ppstrm membersOp =  fun ppTycon1 env ppstrm membersOp =
211      let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm      let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
212          fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =          fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =
213              if !internals              if !internals
214              then (begin_block PP.INCONSISTENT 1;              then (openHOVBox 1;
215                    ppInvPath ppstrm path;                    ppInvPath ppstrm path;
216                    pps "[";                    pps "[";
217                    pps "G"; ppkind ppstrm kind; pps ";";                    pps "G"; ppkind ppstrm kind; pps ";";
# Line 215  Line 219 
219                    pps ";";                    pps ";";
220                    ppEqProp ppstrm (!eq);                    ppEqProp ppstrm (!eq);
221                    pps "]";                    pps "]";
222                    end_block())                    closeBox())
223              else pps(effectivePath(path,tyc,env))              else pps(effectivePath(path,tyc,env))
224            | ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =            | ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =
225               if !internals               if !internals
226               then (begin_block PP.INCONSISTENT 1;               then (openHOVBox 1;
227                      ppInvPath ppstrm path;                      ppInvPath ppstrm path;
228                      pps "["; pps "D;";                      pps "["; pps "D;";
229                      ppType env ppstrm body;                      ppType env ppstrm body;
230                      pps "]";                      pps "]";
231                     end_block())                     closeBox())
232               else pps(effectivePath(path,tyc,env))               else pps(effectivePath(path,tyc,env))
233            | ppTyc(RECORDtyc labels) =            | ppTyc(RECORDtyc labels) =
234                ppClosedSequence ppstrm                ppClosedSequence ppstrm
235                  {front=C PP.add_string "{",                  {front=C PP.string "{",
236                   sep=fn ppstrm => (PP.add_string ppstrm ",";                   sep=fn ppstrm => (PP.string ppstrm ",";
237                                     PP.add_break ppstrm (0,0)),                                     PP.break ppstrm {nsp=0,offset=0}),
238                   back=C PP.add_string "}",                   back=C PP.string "}",
239                   style=PP.INCONSISTENT,                   style=INCONSISTENT,
240                   pr=ppSym} labels                   pr=ppSym} labels
241    
242            | ppTyc (RECtyc n) =            | ppTyc (RECtyc n) =
# Line 255  Line 259 
259    
260            | ppTyc (tyc as PATHtyc{arity,entPath,path}) =            | ppTyc (tyc as PATHtyc{arity,entPath,path}) =
261               if !internals               if !internals
262               then (begin_block PP.INCONSISTENT 1;               then (openHOVBox 1;
263                      ppInvPath ppstrm path; pps "[P;";                      ppInvPath ppstrm path; pps "[P;";
264                      pps (EntPath.entPathToString entPath);                      pps (EntPath.entPathToString entPath);
265                      pps "]";                      pps "]";
266                     end_block())                     closeBox())
267               else ppInvPath ppstrm path               else ppInvPath ppstrm path
268    
269            | ppTyc ERRORtyc = pps "[E]"            | ppTyc ERRORtyc = pps "[E]"
# Line 269  Line 273 
273    
274  and ppType1 env ppstrm (ty: ty, sign: T.polysign,  and ppType1 env ppstrm (ty: ty, sign: T.polysign,
275                          membersOp: (T.dtmember vector * T.tycon list) option) : unit =                          membersOp: (T.dtmember vector * T.tycon list) option) : unit =
276      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
277          fun prty ty =          fun prty ty =
278              case ty              case ty
279                of VARty(ref(INSTANTIATED ty')) => prty(ty')                of VARty(ref(INSTANTIATED ty')) => prty(ty')
# Line 281  Line 285 
285                     end                     end
286                 | CONty(tycon, args) => let                 | CONty(tycon, args) => let
287                       fun otherwise () =                       fun otherwise () =
288                           (begin_block PP.INCONSISTENT 2;                           (openHOVBox 2;
289                            ppTypeArgs args;                            ppTypeArgs args;
290                            add_break(0,0);                            break{nsp=0,offset=0};
291                            ppTycon1 env ppstrm membersOp tycon;                            ppTycon1 env ppstrm membersOp tycon;
292                            end_block())                            closeBox())
293                   in                   in
294                       case tycon                       case tycon
295                        of GENtyc { stamp, kind, ... } =>                        of GENtyc { stamp, kind, ... } =>
# Line 294  Line 298 
298                                if Stamps.eq(stamp,arrowStamp)                                if Stamps.eq(stamp,arrowStamp)
299                                then case args                                then case args
300                                      of [domain,range] =>                                      of [domain,range] =>
301                                         (begin_block PP.CONSISTENT 0;                                         (openHVBox 0;
302                                          if strength domain = 0                                          if strength domain = 0
303                                          then (begin_block PP.CONSISTENT 1;                                          then (openHVBox 1;
304                                                pps "(";                                                pps "(";
305                                                prty domain;                                                prty domain;
306                                                pps ")";                                                pps ")";
307                                                end_block())                                                closeBox())
308                                          else prty domain;                                          else prty domain;
309                                          add_break(1,0);                                          break{nsp=1,offset=0};
310                                          pps "-> ";                                          pps "-> ";
311                                          prty range;                                          prty range;
312                                          end_block())                                          closeBox())
313                                       | _ => bug "CONty:arity"                                       | _ => bug "CONty:arity"
314                                else (begin_block PP.INCONSISTENT 2;                                else (openHOVBox 2;
315                                      ppTypeArgs args;                                      ppTypeArgs args;
316                                      add_break(0,0);                                      break{nsp=0,offset=0};
317                                      ppTycon1 env ppstrm membersOp tycon;                                      ppTycon1 env ppstrm membersOp tycon;
318                                      end_block())                                      closeBox())
319                              | _ => otherwise ())                              | _ => otherwise ())
320                         | RECORDtyc labels =>                         | RECORDtyc labels =>
321                           if Tuples.isTUPLEtyc(tycon)                           if Tuples.isTUPLEtyc(tycon)
# Line 327  Line 331 
331          and ppTypeArgs [] = ()          and ppTypeArgs [] = ()
332            | ppTypeArgs [ty] =            | ppTypeArgs [ty] =
333               (if strength ty <= 1               (if strength ty <= 1
334                then (begin_block PP.INCONSISTENT 1;                then (openHOVBox 1;
335                      pps "(";                      pps "(";
336                      prty ty;                      prty ty;
337                      pps ")";                      pps ")";
338                      end_block())                      closeBox())
339                else prty ty;                else prty ty;
340                add_break(1,0))                break{nsp=1,offset=0})
341            | ppTypeArgs tys =            | ppTypeArgs tys =
342                ppClosedSequence ppstrm                ppClosedSequence ppstrm
343                  {front=C PP.add_string "(",                  {front=C PP.string "(",
344                   sep=fn ppstrm => (PP.add_string ppstrm ",";                   sep=fn ppstrm => (PP.string ppstrm ",";
345                                     PP.add_break ppstrm (0,0)),                                     PP.break ppstrm {nsp=0,offset=0}),
346                   back=C PP.add_string ") ",                   back=C PP.string ") ",
347                   style=PP.INCONSISTENT,                   style=INCONSISTENT,
348                   pr=fn _ => fn ty => prty ty}                   pr=fn _ => fn ty => prty ty}
349                  tys                  tys
350    
351          and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))          and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))
352            | ppTUPLEty tys =            | ppTUPLEty tys =
353                ppSequence ppstrm                ppSequence ppstrm
354                   {sep = fn ppstrm => (PP.add_break ppstrm (1,0);                   {sep = fn ppstrm => (PP.break ppstrm {nsp=1,offset=0};
355                                      PP.add_string ppstrm "* "),                                      PP.string ppstrm "* "),
356                    style = PP.INCONSISTENT,                    style = INCONSISTENT,
357                    pr = (fn _ => fn ty =>                    pr = (fn _ => fn ty =>
358                            if strength ty <= 1                            if strength ty <= 1
359                            then (begin_block PP.INCONSISTENT 1;                            then (openHOVBox 1;
360                                  pps "(";                                  pps "(";
361                                  prty ty;                                  prty ty;
362                                  pps ")";                                  pps ")";
363                                  end_block())                                  closeBox())
364                            else prty ty)}                            else prty ty)}
365                  tys                  tys
366    
367          and ppField(lab,ty) = (begin_block PP.CONSISTENT 0;          and ppField(lab,ty) = (openHVBox 0;
368                                 ppSym ppstrm lab;                                 ppSym ppstrm lab;
369                                 pps ":";                                 pps ":";
370                                 prty ty;                                 prty ty;
371                                 end_block())                                 closeBox())
372    
373          and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))          and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))
374                (* this case should not occur *)                (* this case should not occur *)
375            | ppRECORDty(lab::labels, arg::args) =            | ppRECORDty(lab::labels, arg::args) =
376                (begin_block PP.INCONSISTENT 1;                (openHOVBox 1;
377                 pps "{";                 pps "{";
378                 ppField(lab,arg);                 ppField(lab,arg);
379                 ListPair.app                 ListPair.app
380                   (fn field => (pps ","; add_break(1,0);ppField field))                   (fn field => (pps ","; break{nsp=1,offset=0}; ppField field))
381                   (labels,args);                   (labels,args);
382                 pps "}";                 pps "}";
383                 end_block())                 closeBox())
384            | ppRECORDty _ = bug "PPType.ppRECORDty"            | ppRECORDty _ = bug "PPType.ppRECORDty"
385    
386          and ppTyvar (tv as (ref info) :tyvar) :unit =          and ppTyvar (tv as (ref info) :tyvar) :unit =
# Line 388  Line 392 
392                                (case fields                                (case fields
393                                   of [] => (pps "{"; pps printname; pps "}")                                   of [] => (pps "{"; pps printname; pps "}")
394                                    | field::fields =>                                    | field::fields =>
395                                        (begin_block PP.INCONSISTENT 1;                                        (openHOVBox 1;
396                                         pps "{";                                         pps "{";
397                                         ppField field;                                         ppField field;
398                                         app (fn x => (pps ",";                                         app (fn x => (pps ",";
399                                                       add_break(1,0);                                                       break{nsp=1,offset=0};
400                                                       ppField x))                                                       ppField x))
401                                              fields;                                              fields;
402                                         pps ";";                                         pps ";";
403                                         add_break(1,0);                                         break{nsp=1,offset=0};
404                                         pps printname;                                         pps printname;
405                                         pps "}";                                         pps "}";
406                                         end_block()))                                         closeBox()))
407                             | _ => pps printname)                             | _ => pps printname)
408                     | _ => pps printname                     | _ => pps printname
409              end              end
# Line 407  Line 411 
411      end  (* ppType1 *)      end  (* ppType1 *)
412    
413  and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =  and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =
414        (PP.begin_block ppstrm PP.INCONSISTENT 1;        (PP.openHOVBox ppstrm (PP.Rel 1);
415         ppType1 env ppstrm (ty,[],NONE);         ppType1 env ppstrm (ty,[],NONE);
416         PP.end_block ppstrm)         PP.closeBox ppstrm)
417    
418  fun ppDconDomain members (env:StaticEnv.staticEnv)  fun ppDconDomain members (env:StaticEnv.staticEnv)
419                   ppstrm (ty:ty) : unit =                   ppstrm (ty:ty) : unit =
420        (PP.begin_block ppstrm PP.INCONSISTENT 1;        (PP.openHOVBox ppstrm (PP.Rel 1);
421         ppType1 env ppstrm (ty,[],SOME members);         ppType1 env ppstrm (ty,[],SOME members);
422         PP.end_block ppstrm)         PP.closeBox ppstrm)
423    
424  fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc  fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc
425    
426  fun ppTyfun env ppstrm (TYFUN{arity,body}) =  fun ppTyfun env ppstrm (TYFUN{arity,body}) =
427      let val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm      let val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
428       in begin_block PP.INCONSISTENT 2;       in openHOVBox 2;
429          pps "TYFUN({arity=";          pps "TYFUN({arity=";
430          ppi ppstrm arity; add_comma ppstrm;          ppi ppstrm arity; ppcomma ppstrm;
431          add_break(0,0);          break{nsp=0,offset=0};
432          pps "body=";          pps "body=";
433          ppType env ppstrm body;          ppType env ppstrm body;
434          pps "})";          pps "})";
435          end_block()          closeBox()
436      end      end
437    
438  fun ppFormals ppstrm =  fun ppFormals ppstrm =
# Line 442  Line 446 
446    
447  fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =  fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =
448      let val {index,freetycs,family={members,...},...} = dt      let val {index,freetycs,family={members,...},...} = dt
449          val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm          val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
450          val {dcons,...} = Vector.sub(members,index)          val {dcons,...} = Vector.sub(members,index)
451      in      in
452          begin_block PP.CONSISTENT 0;          openHVBox 0;
453          app (fn {name,domain,...} =>          app (fn {name,domain,...} =>
454                  (pps (Symbol.name name); pps ":";                  (pps (Symbol.name name); pps ":";
455                   case domain                   case domain
456                    of SOME ty =>                    of SOME ty =>
457                       ppType1 env ppstrm (ty,[],SOME (members,freetycs))                       ppType1 env ppstrm (ty,[],SOME (members,freetycs))
458                     | NONE => pps "CONST";                     | NONE => pps "CONST";
459                   add_break(1,0)))                   break{nsp=1,offset=0}))
460              dcons;              dcons;
461              end_block()              closeBox()
462      end      end
463    | ppDataconTypes env ppstrm _ = bug "ppDataconTypes"    | ppDataconTypes env ppstrm _ = bug "ppDataconTypes"
464    

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