ghc/interpreter/output.c

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