ghc/interpreter/output.c

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