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