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