ghc/interpreter/output.c

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