ghc/interpreter/output.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Unparse expressions and types - for use in error messages, type checker
   4  * and for debugging.
   5  *
   6  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   7  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   8  * Technology, 1994-1999, All rights reserved.  It is distributed as
   9  * free software under the license in the file "License", which is
  10  * included in the distribution.
  11  *
  12  * $RCSfile: output.c,v $
  13  * $Revision: 1.7 $
  14  * $Date: 1999/10/16 02:17:28 $
  15  * ------------------------------------------------------------------------*/
  16
  17 #include "prelude.h"
  18 #include "storage.h"
  19 #include "connect.h"
  20 #include "errors.h"
  21 #include <ctype.h>
  22
  23 #define DEPTH_LIMIT     15
  24
  25 /* --------------------------------------------------------------------------
  26  * Local function prototypes:
  27  * ------------------------------------------------------------------------*/
  28
  29 static Void local put            Args((Int,Cell));
  30 static Void local putFlds        Args((Cell,List));
  31 static Void local putComp        Args((Cell,List));
  32 static Void local putQual        Args((Cell));
  33 static Bool local isDictVal      Args((Cell));
  34 static Cell local maySkipDict    Args((Cell));
  35 static Void local putAp          Args((Int,Cell));
  36 static Void local putOverInfix   Args((Int,Text,Syntax,Cell));
  37 static Void local putInfix       Args((Int,Text,Syntax,Cell,Cell));
  38 static Void local putSimpleAp    Args((Cell,Int));
  39 static Void local putTuple       Args((Int,Cell));
  40 static Int  local unusedTups     Args((Int,Cell));
  41 static Void local unlexOp        Args((Text));
  42
  43 static Void local putSigType     Args((Cell));
  44 static Void local putContext     Args((List,List,Int));
  45 static Void local putPred        Args((Cell,Int));
  46 static Void local putType        Args((Cell,Int,Int));
  47 static Void local putTyVar       Args((Int));
  48 static Bool local putTupleType   Args((Cell,Int));
  49 static Void local putApType      Args((Type,Int,Int));
  50
  51 static Void local putKind        Args((Kind));
  52 static Void local putKinds       Args((Kinds));
  53
  54 /* --------------------------------------------------------------------------
  55  * Basic output routines:
  56  * ------------------------------------------------------------------------*/
  57
  58 FILE *outputStream;                    /* current output stream            */
  59 Int  outColumn = 0;                    /* current output column number     */
  60
  61 #define OPEN(b)    if (b) putChr('(');
  62 #define CLOSE(b)   if (b) putChr(')');
  63
  64 Void putChr(c)                         /* print single character           */
  65 Int c; {
  66     Putc(c,outputStream);
  67     outColumn++;
  68 }
  69
  70 Void putStr(s)                        /* print string                     */
  71 String s; {
  72     for (; *s; s++) {
  73         Putc(*s,outputStream);
  74         outColumn++;
  75     }
  76 }
  77
  78 Void putInt(n)                        /* print integer                    */
  79 Int n; {
  80     static char intBuf[16];
  81     sprintf(intBuf,"%d",n);
  82     putStr(intBuf);
  83 }
  84
  85 Void putPtr(p)                        /* print pointer                    */
  86 Ptr p; {
  87     static char intBuf[16];
  88     sprintf(intBuf,"%p",p);
  89     putStr(intBuf);
  90 }
  91
  92 /* --------------------------------------------------------------------------
  93  * Precedence values (See Haskell 1.3 report, p.12):
  94  * ------------------------------------------------------------------------*/
  95
  96 #define ALWAYS      FUN_PREC           /* Always use parens (unless atomic)*/
  97                                        /* User defined operators have prec */
  98                                        /* in the range MIN_PREC..MAX_PREC  */
  99 #define ARROW_PREC  MAX_PREC           /* for printing -> in type exprs    */
 100 #define COCO_PREC   (MIN_PREC-1)       /* :: is left assoc, low precedence */
 101 #define COND_PREC   (MIN_PREC-2)       /* conditional expressions          */
 102 #define WHERE_PREC  (MIN_PREC-3)       /* where expressions                */
 103 #define LAM_PREC    (MIN_PREC-4)       /* lambda abstraction               */
 104 #define NEVER       LAM_PREC           /* Never use parentheses            */
 105
 106
 107 /* --------------------------------------------------------------------------
 108  * Print an expression (used to display context of type errors):
 109  * ------------------------------------------------------------------------*/
 110
 111 static Int putDepth = 0;               /* limits depth of printing DBG     */
 112
 113 static Void local put(d,e)             /* print expression e in context of */
 114 Int  d;                                /* operator of precedence d         */
 115 Cell e; {
 116     List xs;
 117
 118     if (putDepth>DEPTH_LIMIT) {
 119         putStr("...");
 120         return;
 121     }
 122     else
 123         putDepth++;
 124
 125     switch (whatIs(e)) {
 126         case FINLIST    : putChr('[');
 127                           xs = snd(e);
 128                           if (nonNull(xs)) {
 129                               put(NEVER,hd(xs));
 130                               while (nonNull(xs=tl(xs))) {
 131                                   putChr(',');
 132                                   put(NEVER,hd(xs));
 133                               }
 134                           }
 135                           putChr(']');
 136                           break;
 137
 138         case AP         : putAp(d,e);
 139                           break;
 140
 141         case NAME       : unlexVar(name(e).text);
 142                           break;
 143
 144         case VARIDCELL  :
 145         case VAROPCELL  :
 146         case DICTVAR    :
 147         case CONIDCELL  :
 148         case CONOPCELL  : unlexVar(textOf(e));
 149                           break;
 150
 151 #if TREX
 152         case RECSEL     : putChr('#');
 153                           unlexVar(extText(snd(e)));
 154                           break;
 155 #endif
 156
 157         case FREECELL   : putStr("{free!}");
 158                           break;
 159
 160         case TUPLE      : putTuple(tupleOf(e),e);
 161                           break;
 162
 163         case WILDCARD   : putChr('_');
 164                           break;
 165
 166         case ASPAT      : put(NEVER,fst(snd(e)));
 167                           putChr('@');
 168                           put(ALWAYS,snd(snd(e)));
 169                           break;
 170
 171         case LAZYPAT    : putChr('~');
 172                           put(ALWAYS,snd(e));
 173                           break;
 174
 175         case DOCOMP     : putStr("do {...}");
 176                           break;
 177
 178         case COMP       : putComp(fst(snd(e)),snd(snd(e)));
 179                           break;
 180
 181         case MONADCOMP  : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
 182                           break;
 183
 184         case CHARCELL   : unlexCharConst(charOf(e));
 185                           break;
 186
 187         case INTCELL    : {   Int i = intOf(e);
 188                               if (i<0 && d>=UMINUS_PREC) putChr('(');
 189                               putInt(i);
 190                               if (i<0 && d>=UMINUS_PREC) putChr(')');
 191                           }
 192                           break;
 193
 194         case FLOATCELL  : {   Float f = floatOf(e);
 195                               if (f<0 && d>=UMINUS_PREC) putChr('(');
 196                               putStr(floatToString(f));
 197                               if (f<0 && d>=UMINUS_PREC) putChr(')');
 198                           }
 199                           break;
 200
 201         case STRCELL    : unlexStrConst(textOf(e));
 202                           break;
 203
 204         case LETREC     : OPEN(d>WHERE_PREC);
 205 #if DEBUG_CODE
 206                           putStr("let {");
 207                           put(NEVER,fst(snd(e)));
 208                           putStr("} in ");
 209 #else
 210                           putStr("let {...} in ");
 211 #endif
 212                           put(WHERE_PREC+1,snd(snd(e)));
 213                           CLOSE(d>WHERE_PREC);
 214                           break;
 215
 216         case COND       : OPEN(d>COND_PREC);
 217                           putStr("if ");
 218                           put(COND_PREC+1,fst3(snd(e)));
 219                           putStr(" then ");
 220                           put(COND_PREC+1,snd3(snd(e)));
 221                           putStr(" else ");
 222                           put(COND_PREC+1,thd3(snd(e)));
 223                           CLOSE(d>COND_PREC);
 224                           break;
 225
 226         case LAMBDA     : xs = fst(snd(e));
 227                           if (whatIs(xs)==BIGLAM)
 228                               xs = snd(snd(xs));
 229                           while (nonNull(xs) && isDictVal(hd(xs)))
 230                               xs = tl(xs);
 231                           if (isNull(xs)) {
 232                               put(d,snd(snd(snd(e))));
 233                               break;
 234                           }
 235                           OPEN(d>LAM_PREC);
 236                           putChr('\\');
 237                           if (nonNull(xs)) {
 238                               put(ALWAYS,hd(xs));
 239                               while (nonNull(xs=tl(xs))) {
 240                                   putChr(' ');
 241                                   put(ALWAYS,hd(xs));
 242                               }
 243                           }
 244                           putStr(" -> ");
 245                           put(LAM_PREC,snd(snd(snd(e))));
 246                           CLOSE(d>LAM_PREC);
 247                           break;
 248
 249         case ESIGN      : OPEN(d>COCO_PREC);
 250                           put(COCO_PREC,fst(snd(e)));
 251                           putStr(" :: ");
 252                           putSigType(snd(snd(e)));
 253                           CLOSE(d>COCO_PREC);
 254                           break;
 255
 256         case BIGLAM     : put(d,snd(snd(e)));
 257                           break;
 258
 259         case CASE       : putStr("case ");
 260                           put(NEVER,fst(snd(e)));
 261 #if DEBUG_CODE
 262                           putStr(" of {");
 263                           put(NEVER,snd(snd(e)));
 264                           putChr('}');
 265 #else
 266                           putStr(" of {...}");
 267 #endif
 268                           break;
 269
 270         case CONFLDS    : putFlds(fst(snd(e)),snd(snd(e)));
 271                           break;
 272
 273         case UPDFLDS    : putFlds(fst3(snd(e)),thd3(snd(e)));
 274                           break;
 275
 276         default         : /*internal("put");*/
 277                           putChr('$');
 278                           putInt(e);
 279                           break;
 280     }
 281     putDepth--;
 282 }
 283
 284 static Void local putFlds(exp,fs)       /* Output exp using labelled fields*/
 285 Cell exp;
 286 List fs; {
 287     put(ALWAYS,exp);
 288     putChr('{');
 289     for (; nonNull(fs); fs=tl(fs)) {
 290         Cell v = hd(fs);
 291         if (isVar(v))
 292             put(NEVER,v);
 293         else {
 294             Cell f = fst(v);
 295             Cell e = snd(v);
 296             Text t = isName(f) ? name(f).text :
 297                      isVar(f)  ? textOf(f)    : inventText();
 298             Text s = isName(e) ? name(e).text :
 299                      isVar(e)  ? textOf(e)    : inventText();
 300
 301             put(NEVER,f);
 302             if (haskell98 || s!=t) {
 303                 putStr(" = ");
 304                 put(NEVER,e);
 305             }
 306         }
 307         if (nonNull(tl(fs)))
 308             putStr(", ");
 309     }
 310     putChr('}');
 311 }
 312
 313 static Void local putComp(e,qs)         /* print comprehension             */
 314 Cell e;
 315 List qs; {
 316     putStr("[ ");
 317     put(NEVER,e);
 318     if (nonNull(qs)) {
 319         putStr(" | ");
 320         putQual(hd(qs));
 321         while (nonNull(qs=tl(qs))) {
 322             putStr(", ");
 323             putQual(hd(qs));
 324         }
 325     }
 326     putStr(" ]");
 327 }
 328
 329 static Void local putQual(q)            /* print list comp qualifier       */
 330 Cell q; {
 331     switch (whatIs(q)) {
 332         case BOOLQUAL : put(NEVER,snd(q));
 333                         return;
 334
 335         case QWHERE   : putStr("let {...}");
 336                         return;
 337
 338         case FROMQUAL : put(ALWAYS,fst(snd(q)));
 339                         putStr("<-");
 340                         put(NEVER,snd(snd(q)));
 341                         return;
 342     }
 343 }
 344
 345 static Bool local isDictVal(e)          /* Look for dictionary value       */
 346 Cell e; {
 347 #if !DEBUG_CODE
 348     Cell h = getHead(e);
 349     switch (whatIs(h)) {
 350         case DICTVAR : return TRUE;
 351         case NAME    : return isDfun(h);
 352     }
 353 #endif
 354     return FALSE;
 355 }
 356
 357 static Cell local maySkipDict(e)        /* descend function application,   */
 358 Cell e; {                               /* ignoring dict aps               */
 359     while (isAp(e) && isDictVal(arg(e)))
 360         e = fun(e);
 361     return e;
 362 }
 363
 364 static Void local putAp(d,e)            /* print application (args>=1)     */
 365 Int  d;
 366 Cell e; {
 367     Cell   h;
 368     Text   t;
 369     Syntax sy;
 370     Int    args = 0;
 371
 372     for (h=e; isAp(h); h=fun(h))        /* find head of expression, looking*/
 373         if (!isDictVal(arg(h)))         /* for dictionary arguments        */
 374             args++;
 375
 376     if (args==0) {                      /* Special case when *all* args    */
 377         put(d,h);                       /* are dictionary values           */
 378         return;
 379     }
 380
 381     switch (whatIs(h)) {
 382 #if NPLUSK
 383         case ADDPAT     : if (args==1)
 384                               putInfix(d,textPlus,syntaxOf(namePlus),
 385                                          arg(e),mkInt(intValOf(fun(e))));
 386                           else
 387                               putStr("ADDPAT");
 388                           return;
 389 #endif
 390
 391         case TUPLE      : OPEN(args>tupleOf(h) && d>=FUN_PREC);
 392                           putTuple(tupleOf(h),e);
 393                           CLOSE(args>tupleOf(h) && d>=FUN_PREC);
 394                           return;
 395
 396         case NAME       : if (args==1 &&
 397                               ((h==nameFromInt     && isInt(arg(e)))    ||
 398                                (h==nameFromDouble  && isFloat(arg(e))))) {
 399                               put(d,arg(e));
 400                               return;
 401                           }
 402                           t  = name(h).text;
 403                           sy = syntaxOf(h);
 404                           break;
 405
 406         case VARIDCELL  :
 407         case VAROPCELL  :
 408         case DICTVAR    :
 409         case CONIDCELL  :
 410         case CONOPCELL  : sy = defaultSyntax(t = textOf(h));
 411                           break;
 412
 413 #if TREX
 414         case EXT        : if (args==2) {
 415                               String punc = "(";
 416                               do {
 417                                   putStr(punc);
 418                                   punc = ", ";
 419                                   putStr(textToStr(extText(h)));
 420                                   putStr("=");
 421                                   put(NEVER,extField(e));
 422                                   args = 0;
 423                                   e    = extRow(e);
 424                                   for (h=e; isAp(h); h=fun(h))
 425                                       if (!isDictVal(arg(h)))
 426                                           args++;
 427                               } while (isExt(h) && args==2);
 428                               if (e!=nameNoRec) {
 429                                   putStr(" | ");
 430                                   put(NEVER,e);
 431                               }
 432                               putChr(')');
 433                               return;
 434                           }
 435                           else if (args<2)
 436                               internal("putExt");
 437                           else
 438                               args-=2;
 439                           break;
 440 #endif
 441
 442         default         : sy = APPLIC;
 443                           break;
 444     }
 445
 446     e = maySkipDict(e);
 447
 448     if (sy==APPLIC) {                   /* print simple application        */
 449         OPEN(d>=FUN_PREC);
 450         putSimpleAp(e,args);
 451         CLOSE(d>=FUN_PREC);
 452         return;
 453     }
 454     else if (args==1) {                 /* print section of the form (e+)  */
 455         putChr('(');
 456         put(FUN_PREC-1,arg(e));
 457         putChr(' ');
 458         unlexOp(t);
 459         putChr(')');
 460     }
 461     else if (args==2)                  /* infix expr of the form e1 + e2   */
 462         putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
 463     else {                             /* o/w (e1 + e2) e3 ... en   (n>=3) */
 464         OPEN(d>=FUN_PREC);
 465         putOverInfix(args,t,sy,e);
 466         CLOSE(d>=FUN_PREC);
 467     }
 468 }
 469
 470 static Void local putOverInfix(args,t,sy,e)
 471 Int    args;                           /* infix applied to >= 3 arguments  */
 472 Text   t;
 473 Syntax sy;
 474 Cell   e; {
 475     if (args>2) {
 476         putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
 477         putChr(' ');
 478         put(FUN_PREC,arg(e));
 479     }
 480     else
 481         putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
 482 }
 483
 484 static Void local putInfix(d,t,sy,e,f)  /* print infix expression          */
 485 Int    d;
 486 Text   t;                               /* Infix operator symbol           */
 487 Syntax sy;                              /* with name t, syntax s           */
 488 Cell   e, f; {                          /* Left and right operands         */
 489     Syntax a = assocOf(sy);
 490     Int    p = precOf(sy);
 491
 492     OPEN(d>p);
 493     put((a==LEFT_ASS ? p : 1+p), e);
 494     putChr(' ');
 495     unlexOp(t);
 496     putChr(' ');
 497     put((a==RIGHT_ASS ? p : 1+p), f);
 498     CLOSE(d>p);
 499 }
 500
 501 static Void local putSimpleAp(e,n)      /* print application e0 e1 ... en  */
 502 Cell e;
 503 Int  n; {
 504     if (n>0) {
 505         putSimpleAp(maySkipDict(fun(e)),n-1);
 506         putChr(' ');
 507         put(FUN_PREC,arg(e));
 508     }
 509     else
 510         put(FUN_PREC,e);
 511 }
 512
 513 static Void local putTuple(ts,e)        /* Print tuple expression, allowing*/
 514 Int  ts;                                /* for possibility of either too   */
 515 Cell e; {                               /* few or too many args to constr  */
 516     Int i;
 517     putChr('(');
 518     if ((i=unusedTups(ts,e))>0) {
 519         while (--i>0)
 520             putChr(',');
 521         putChr(')');
 522     }
 523 }
 524
 525 static Int local unusedTups(ts,e)       /* print first part of tuple expr  */
 526 Int  ts;                                /* returning number of constructor */
 527 Cell e; {                               /* args not yet printed ...        */
 528     if (isAp(e)) {
 529         if ((ts=unusedTups(ts,fun(e))-1)>=0) {
 530             put(NEVER,arg(e));
 531             putChr(ts>0?',':')');
 532         }
 533         else {
 534             putChr(' ');
 535             put(FUN_PREC,arg(e));
 536         }
 537     }
 538     return ts;
 539 }
 540
 541 Void unlexVar(t)                       /* print text as a variable name    */
 542 Text t; {                              /* operator symbols must be enclosed*/
 543     String s = textToStr(t);           /* in parentheses... except [] ...  */
 544
 545     if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
 546        || s[0]=='_' || s[0]=='[' || s[0]=='(')
 547         putStr(s);
 548     else {
 549         putChr('(');
 550         putStr(s);
 551         putChr(')');
 552     }
 553 }
 554
 555 static Void local unlexOp(t)           /* print text as operator name      */
 556 Text t; {                              /* alpha numeric symbols must be    */
 557     String s = textToStr(t);           /* enclosed by backquotes           */
 558
 559     if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
 560         putChr('`');
 561         putStr(s);
 562         putChr('`');
 563     }
 564     else
 565         putStr(s);
 566 }
 567
 568 Void unlexCharConst(c)
 569 Cell c; {
 570     putChr('\'');
 571     putStr(unlexChar(c,'\''));
 572     putChr('\'');
 573 }
 574
 575 Void unlexStrConst(t)
 576 Text t; {
 577     String s            = textToStr(t);
 578     static Char SO      = 14;          /* ASCII code for '\SO'             */
 579     Bool   lastWasSO    = FALSE;
 580     Bool   lastWasDigit = FALSE;
 581     Bool   lastWasEsc   = FALSE;
 582
 583     putChr('\"');
 584     for (; *s; s++) {
 585         String ch = unlexChar(*s,'\"');
 586         Char   c  = ' ';
 587
 588         if ((lastWasSO && *ch=='H') ||
 589                 (lastWasEsc && lastWasDigit
 590                  && isascii((int)(*ch)) && isdigit((int)(*ch))))
 591             putStr("\\&");
 592
 593         lastWasEsc   = (*ch=='\\');
 594         lastWasSO    = (*s==SO);
 595         for (; *ch; c = *ch++)
 596             putChr(*ch);
 597         lastWasDigit = (isascii(c) && isdigit(c));
 598     }
 599     putChr('\"');
 600 }
 601
 602 /* --------------------------------------------------------------------------
 603  * Print type expression:
 604  * ------------------------------------------------------------------------*/
 605
 606 static Void local putSigType(t)         /* print (possibly) generic type   */
 607 Cell t; {
 608     Int fr = 0;
 609     if (isPolyType(t)) {
 610         Kinds ks = polySigOf(t);
 611         for (; isAp(ks); ks=tl(ks))
 612             fr++;
 613         t = monotypeOf(t);
 614     }
 615
 616     putType(t,NEVER,fr);                /* Finally, print rest of type ... */
 617 }
 618
 619 static Void local putContext(ps,qs,fr)  /* print context list              */
 620 List ps;
 621 List qs;
 622 Int  fr; {
 623     Int len = length(ps) + length(qs);
 624     Int c   = len;
 625     if (len!=1) {
 626         putChr('(');
 627     }
 628     for (; nonNull(ps); ps=tl(ps)) {
 629         putPred(hd(ps),fr);
 630         if (--c > 0) {
 631             putStr(", ");
 632         }
 633     }
 634     for (; nonNull(qs); qs=tl(qs)) {
 635         putPred(hd(qs),fr);
 636         if (--c > 0) {
 637             putStr(", ");
 638         }
 639     }
 640     if (len!=1) {
 641         putChr(')');
 642     }
 643 }
 644
 645 static Void local putPred(pi,fr)        /* Output predicate                */
 646 Cell pi;
 647 Int  fr; {
 648     if (isAp(pi)) {
 649 #if TREX
 650         if (isExt(fun(pi))) {
 651             putType(arg(pi),ALWAYS,fr);
 652             putChr('\\');
 653             putStr(textToStr(extText(fun(pi))));
 654             return;
 655         }
 656 #endif
 657         putPred(fun(pi),fr);
 658         putChr(' ');
 659         putType(arg(pi),ALWAYS,fr);
 660     }
 661     else if (isClass(pi))
 662         putStr(textToStr(cclass(pi).text));
 663     else if (isCon(pi))
 664         putStr(textToStr(textOf(pi)));
 665     else
 666         putStr("<unknownPredicate>");
 667 }
 668
 669 static Void local putType(t,prec,fr)    /* print nongeneric type expression*/
 670 Cell t;
 671 Int  prec;
 672 Int  fr; {
 673     switch(whatIs(t)) {
 674         case TYCON     : putStr(textToStr(tycon(t).text));
 675                          break;
 676
 677         case TUPLE     : {   Int n = tupleOf(t);
 678                              putChr('(');
 679                              while (--n > 0)
 680                                  putChr(',');
 681                              putChr(')');
 682                          }
 683                          break;
 684
 685         case POLYTYPE  : {   Kinds ks = polySigOf(t);
 686                              OPEN(prec>=ARROW_PREC);
 687                              putStr("forall ");
 688                              for (; isAp(ks); ks=tl(ks)) {
 689                                  putTyVar(fr++);
 690                                  if (isAp(tl(ks)))
 691                                      putChr(',');
 692                              }
 693                              putStr(". ");
 694                              putType(monotypeOf(t),NEVER,fr);
 695                              CLOSE(prec>=ARROW_PREC);
 696                          }
 697                          break;
 698
 699         case CDICTS    :
 700         case QUAL      : OPEN(prec>=ARROW_PREC);
 701                          if (whatIs(snd(snd(t)))==CDICTS) {
 702                              putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
 703                              putStr(" => ");
 704                              putType(snd(snd(snd(snd(t)))),NEVER,fr);
 705                          } else {
 706                              putContext(fst(snd(t)),NIL,fr);
 707                              putStr(" => ");
 708                              putType(snd(snd(t)),NEVER,fr);
 709                          }
 710                          CLOSE(prec>=ARROW_PREC);
 711                          break;
 712
 713         case EXIST     :
 714         case RANK2     : putType(snd(snd(t)),prec,fr);
 715                          break;
 716
 717         case OFFSET    : putTyVar(offsetOf(t));
 718                          break;
 719
 720         case VARIDCELL :
 721         case VAROPCELL : putChr('_');
 722                          unlexVar(textOf(t));
 723                          break;
 724
 725         case INTCELL   : putChr('_');
 726                          putInt(intOf(t));
 727                          break;
 728
 729         case AP       : {   Cell typeHead = getHead(t);
 730                             Bool brackets = (argCount!=0 && prec>=ALWAYS);
 731                             Int  args    = argCount;
 732
 733                             if (typeHead==typeList) {
 734                                 if (argCount==1) {
 735                                     putChr('[');
 736                                     putType(arg(t),NEVER,fr);
 737                                     putChr(']');
 738                                     return;
 739                                 }
 740                             }
 741                             else if (typeHead==typeArrow) {
 742                                 if (argCount==2) {
 743                                     OPEN(prec>=ARROW_PREC);
 744                                     putType(arg(fun(t)),ARROW_PREC,fr);
 745                                     putStr(" -> ");
 746                                     putType(arg(t),NEVER,fr);
 747                                     CLOSE(prec>=ARROW_PREC);
 748                                     return;
 749                                 }
 750                                 else if (argCount==1) {
 751                                     putChr('(');
 752                                     putType(arg(t),ARROW_PREC,fr);
 753                                     putStr("->)");
 754                                     return;
 755                                 }
 756                             }
 757                             else if (isTuple(typeHead)) {
 758                                 if (argCount==tupleOf(typeHead)) {
 759                                     putChr('(');
 760                                     putTupleType(t,fr);
 761                                     putChr(')');
 762                                     return;
 763                                 }
 764                             }
 765 #if TREX
 766                             else if (isExt(typeHead)) {
 767                                 if (args==2) {
 768                                     String punc = "(";
 769                                     do {
 770                                         putStr(punc);
 771                                         punc = ", ";
 772                                         putStr(textToStr(extText(typeHead)));
 773                                         putStr("::");
 774                                         putType(extField(t),NEVER,fr);
 775                                         t        = extRow(t);
 776                                         typeHead = getHead(t);
 777                                     } while (isExt(typeHead) && argCount==2);
 778                                     if (t!=typeNoRow) {
 779                                         putStr(" | ");
 780                                         putType(t,NEVER,fr);
 781                                     }
 782                                     putChr(')');
 783                                     return;
 784                                 }
 785                                 else if (args<2)
 786                                     internal("putExt");
 787                                 else
 788                                     args-=2;
 789                             }
 790 #endif
 791                             OPEN(brackets);
 792                             putApType(t,args,fr);
 793                             CLOSE(brackets);
 794                         }
 795                         break;
 796
 797         default       : putStr("(bad type)");
 798     }
 799 }
 800
 801 static Void local putTyVar(n)           /* print type variable             */
 802 Int n; {
 803     static String alphabet              /* for the benefit of EBCDIC :-)   */
 804                 ="abcdefghijklmnopqrstuvwxyz";
 805     putChr(alphabet[n%26]);
 806     if (n /= 26)                        /* just in case there are > 26 vars*/
 807         putInt(n);
 808 }
 809
 810 static Bool local putTupleType(e,fr)    /* print tuple of types, returning */
 811 Cell e;                                 /* TRUE if something was printed,  */
 812 Int  fr; {                              /* FALSE otherwise; used to control*/
 813     if (isAp(e)) {                      /* printing of intermed. commas    */
 814         if (putTupleType(fun(e),fr))
 815             putChr(',');
 816         putType(arg(e),NEVER,fr);
 817         return TRUE;
 818     }
 819     return FALSE;
 820 }
 821
 822 static Void local putApType(t,n,fr)     /* print type application          */
 823 Cell t;
 824 Int  n;
 825 Int  fr; {
 826     if (n>0) {
 827         putApType(fun(t),n-1,fr);
 828         putChr(' ');
 829         putType(arg(t),ALWAYS,fr);
 830     }
 831     else
 832         putType(t,ALWAYS,fr);
 833 }
 834
 835 /* --------------------------------------------------------------------------
 836  * Print kind expression:
 837  * ------------------------------------------------------------------------*/
 838
 839 static Void local putKind(k)            /* print kind expression           */
 840 Kind k; {
 841     switch (whatIs(k)) {
 842         case AP      : if (isAp(fst(k))) {
 843                            putChr('(');
 844                            putKind(fst(k));
 845                            putChr(')');
 846                        }
 847                        else
 848                            putKind(fst(k));
 849                        putStr(" -> ");
 850                        putKind(snd(k));
 851                        break;
 852
 853 #if TREX
 854         case ROW     : putStr("row");
 855                        break;
 856 #endif
 857
 858         case STAR    : putChr('*');
 859                        break;
 860
 861         case OFFSET  : putTyVar(offsetOf(k));
 862                        break;
 863
 864         case INTCELL : putChr('_');
 865                        putInt(intOf(k));
 866                        break;
 867
 868         default      : putStr("(bad kind)");
 869     }
 870 }
 871
 872 static Void local putKinds(ks)          /* Print list of kinds             */
 873 Kinds ks; {
 874     if (isNull(ks))
 875         putStr("()");
 876     else if (nonNull(tl(ks))) {
 877         putChr('(');
 878         putKind(hd(ks));
 879         while (nonNull(ks=tl(ks))) {
 880             putChr(',');
 881             putKind(hd(ks));
 882         }
 883         putChr(')');
 884     }
 885     else
 886         putKind(hd(ks));
 887 }
 888
 889 /* --------------------------------------------------------------------------
 890  * Main drivers:
 891  * ------------------------------------------------------------------------*/
 892
 893 Void printExp(fp,e)                     /* print expr on specified stream  */
 894 FILE *fp;
 895 Cell e; {
 896     outputStream = fp;
 897     putDepth     = 0;
 898     put(NEVER,e);
 899 }
 900
 901 Void printType(fp,t)                    /* print type on specified stream  */
 902 FILE *fp;
 903 Cell t; {
 904     outputStream = fp;
 905     putSigType(t);
 906 }
 907
 908 Void printContext(fp,qs)                /* print context on spec. stream   */
 909 FILE *fp;
 910 List qs; {
 911     outputStream = fp;
 912     putContext(qs,NIL,0);
 913 }
 914
 915 Void printPred(fp,pi)                   /* print predicate pi on stream    */
 916 FILE *fp;
 917 Cell pi; {
 918     outputStream = fp;
 919     putPred(pi,0);
 920 }
 921
 922 Void printKind(fp,k)                    /* print kind k on stream          */
 923 FILE *fp;
 924 Kind k; {
 925     outputStream = fp;
 926     putKind(k);
 927 }
 928
 929 Void printKinds(fp,ks)                  /* print list of kinds on stream   */
 930 FILE  *fp;
 931 Kinds ks; {
 932     outputStream = fp;
 933     putKinds(ks);
 934 }
 935
 936 Void printFD(fp,fd)                     /* print functional dependency     */
 937 FILE* fp;
 938 Pair  fd; {
 939     List us;
 940     outputStream = fp;
 941     for (us=fst(fd); nonNull(us); us=tl(us)) {
 942         putTyVar(offsetOf(hd(us)));
 943         if (nonNull(tl(us))) {
 944             putChr(' ');
 945         }
 946     }
 947     putStr(" -> ");
 948     for (us=snd(fd); nonNull(us); us=tl(us)) {
 949         putTyVar(offsetOf(hd(us)));
 950         if (nonNull(tl(us))) {
 951             putChr(' ');
 952         }
 953     }
 954 }
 955
 956 /*-------------------------------------------------------------------------*/