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.18 $
  14  * $Date: 2000/04/25 17:43:50 $
  15  * ------------------------------------------------------------------------*/
  16
  17 #include "hugsbasictypes.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            ( Int,Cell );
  30 static Void local putFlds        ( Cell,List );
  31 static Void local putComp        ( Cell,List );
  32 static Void local putQual        ( Cell );
  33 static Bool local isDictVal      ( Cell );
  34 static Cell local maySkipDict    ( Cell );
  35 static Void local putAp          ( Int,Cell );
  36 static Void local putOverInfix   ( Int,Text,Syntax,Cell );
  37 static Void local putInfix       ( Int,Text,Syntax,Cell,Cell );
  38 static Void local putSimpleAp    ( Cell,Int );
  39 static Void local putTuple       ( Int,Cell );
  40 static Int  local unusedTups     ( Int,Cell );
  41 static Void local unlexOp        ( Text );
  42
  43 static Void local putSigType     ( Cell );
  44 static Void local putContext     ( List,List,Int );
  45 static Void local putPred        ( Cell,Int );
  46 static Void local putType        ( Cell,Int,Int );
  47 static Void local putTyVar       ( Int );
  48 static Bool local putTupleType   ( Cell,Int );
  49 static Void local putApType      ( Type,Int,Int );
  50
  51 static Void local putKind        ( Kind );
  52 static Void local putKinds       ( 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 MDOCOMP    : putStr("do {...}");
 192                           break;
 193
 194         case COMP       : putComp(fst(snd(e)),snd(snd(e)));
 195                           break;
 196
 197         case MONADCOMP  : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
 198                           break;
 199
 200         case CHARCELL   : unlexCharConst(charOf(e));
 201                           break;
 202
 203         case INTCELL    : {   Int i = intOf(e);
 204                               if (i<0 && d>=UMINUS_PREC) putChr('(');
 205                               putInt(i);
 206                               if (i<0 && d>=UMINUS_PREC) putChr(')');
 207                           }
 208                           break;
 209
 210         case FLOATCELL  : {   Float f = floatOf(e);
 211                               if (f<0 && d>=UMINUS_PREC) putChr('(');
 212                               putStr(floatToString(e));
 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 0
 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 0
 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 0   /* was !DEBUG_CODE -- is it necessary? */
 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 = 0;                       /* bogus init to keep gcc -O happy */
 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         case ADDPAT     : if (args==1)
 399                               putInfix(d,textPlus,syntaxOf(namePlus),
 400                                          arg(e),mkInt(intValOf(fun(e))));
 401                           else
 402                               putStr("ADDPAT");
 403                           return;
 404
 405         case TUPLE      : OPEN(args>tupleOf(h) && d>=FUN_PREC);
 406                           putTuple(tupleOf(h),e);
 407                           CLOSE(args>tupleOf(h) && d>=FUN_PREC);
 408                           return;
 409
 410         case NAME       : if (args==1 &&
 411                               ((h==nameFromInt     && isInt(arg(e)))    ||
 412                                (h==nameFromDouble  && isFloat(arg(e))))) {
 413                               put(d,arg(e));
 414                               return;
 415                           }
 416                           t  = name(h).text;
 417                           sy = syntaxOf(h);
 418                           break;
 419
 420         case VARIDCELL  :
 421         case VAROPCELL  :
 422         case DICTVAR    :
 423         case CONIDCELL  :
 424         case CONOPCELL  : sy = defaultSyntax(t = textOf(h));
 425                           break;
 426
 427 #if TREX
 428         case EXT        : if (args==2) {
 429                               String punc = "(";
 430                               do {
 431                                   putStr(punc);
 432                                   punc = ", ";
 433                                   putStr(textToStr(extText(h)));
 434                                   putStr("=");
 435                                   put(NEVER,extField(e));
 436                                   args = 0;
 437                                   e    = extRow(e);
 438                                   for (h=e; isAp(h); h=fun(h))
 439                                       if (!isDictVal(arg(h)))
 440                                           args++;
 441                               } while (isExt(h) && args==2);
 442                               if (e!=nameNoRec) {
 443                                   putStr(" | ");
 444                                   put(NEVER,e);
 445                               }
 446                               putChr(')');
 447                               return;
 448                           }
 449                           else if (args<2)
 450                               internal("putExt");
 451                           else
 452                               args-=2;
 453                           break;
 454 #endif
 455
 456         default         : sy = APPLIC;
 457                           break;
 458     }
 459
 460     e = maySkipDict(e);
 461
 462     if (sy==APPLIC) {                   /* print simple application        */
 463         OPEN(d>=FUN_PREC);
 464         putSimpleAp(e,args);
 465         CLOSE(d>=FUN_PREC);
 466         return;
 467     }
 468     else if (args==1) {                 /* print section of the form (e+)  */
 469         putChr('(');
 470         put(FUN_PREC-1,arg(e));
 471         putChr(' ');
 472         unlexOp(t);
 473         putChr(')');
 474     }
 475     else if (args==2)                  /* infix expr of the form e1 + e2   */
 476         putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
 477     else {                             /* o/w (e1 + e2) e3 ... en   (n>=3) */
 478         OPEN(d>=FUN_PREC);
 479         putOverInfix(args,t,sy,e);
 480         CLOSE(d>=FUN_PREC);
 481     }
 482 }
 483
 484 static Void local putOverInfix(args,t,sy,e)
 485 Int    args;                           /* infix applied to >= 3 arguments  */
 486 Text   t;
 487 Syntax sy;
 488 Cell   e; {
 489     if (args>2) {
 490         putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
 491         putChr(' ');
 492         put(FUN_PREC,arg(e));
 493     }
 494     else
 495         putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
 496 }
 497
 498 static Void local putInfix(d,t,sy,e,f)  /* print infix expression          */
 499 Int    d;
 500 Text   t;                               /* Infix operator symbol           */
 501 Syntax sy;                              /* with name t, syntax s           */
 502 Cell   e, f; {                          /* Left and right operands         */
 503     Syntax a = assocOf(sy);
 504     Int    p = precOf(sy);
 505
 506     OPEN(d>p);
 507     put((a==LEFT_ASS ? p : 1+p), e);
 508     putChr(' ');
 509     unlexOp(t);
 510     putChr(' ');
 511     put((a==RIGHT_ASS ? p : 1+p), f);
 512     CLOSE(d>p);
 513 }
 514
 515 static Void local putSimpleAp(e,n)      /* print application e0 e1 ... en  */
 516 Cell e;
 517 Int  n; {
 518     if (n>0) {
 519         putSimpleAp(maySkipDict(fun(e)),n-1);
 520         putChr(' ');
 521         put(FUN_PREC,arg(e));
 522     }
 523     else
 524         put(FUN_PREC,e);
 525 }
 526
 527 static Void local putTuple(ts,e)        /* Print tuple expression, allowing*/
 528 Int  ts;                                /* for possibility of either too   */
 529 Cell e; {                               /* few or too many args to constr  */
 530     Int i;
 531     putChr('(');
 532     if ((i=unusedTups(ts,e))>0) {
 533         while (--i>0)
 534             putChr(',');
 535         putChr(')');
 536     }
 537 }
 538
 539 static Int local unusedTups(ts,e)       /* print first part of tuple expr  */
 540 Int  ts;                                /* returning number of constructor */
 541 Cell e; {                               /* args not yet printed ...        */
 542     if (isAp(e)) {
 543         if ((ts=unusedTups(ts,fun(e))-1)>=0) {
 544             put(NEVER,arg(e));
 545             putChr(ts>0?',':')');
 546         }
 547         else {
 548             putChr(' ');
 549             put(FUN_PREC,arg(e));
 550         }
 551     }
 552     return ts;
 553 }
 554
 555 Void unlexVarStr(s)
 556 String s; {
 557     if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
 558         || s[0]=='_' || s[0]=='[' || s[0]=='('
 559         || s[0]=='$'
 560         || (s[0]==':' && s[1]=='D')
 561        )
 562         putStr(s);
 563     else {
 564         putChr('(');
 565         putStr(s);
 566         putChr(')');
 567     }
 568 }
 569
 570 Void unlexVar(t)                       /* print text as a variable name    */
 571 Text t; {                              /* operator symbols must be enclosed*/
 572     unlexVarStr(textToStr(t));         /* in parentheses... except [] ...  */
 573 }
 574
 575 static Void local unlexOp(t)           /* print text as operator name      */
 576 Text t; {                              /* alpha numeric symbols must be    */
 577     String s = textToStr(t);           /* enclosed by backquotes           */
 578
 579     if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
 580         putChr('`');
 581         putStr(s);
 582         putChr('`');
 583     }
 584     else
 585         putStr(s);
 586 }
 587
 588 Void unlexCharConst(c)
 589 Cell c; {
 590     putChr('\'');
 591     putStr(unlexChar(c,'\''));
 592     putChr('\'');
 593 }
 594
 595 Void unlexStrConst(t)
 596 Text t; {
 597     String s            = textToStr(t);
 598     static Char SO      = 14;          /* ASCII code for '\SO'             */
 599     Bool   lastWasSO    = FALSE;
 600     Bool   lastWasDigit = FALSE;
 601     Bool   lastWasEsc   = FALSE;
 602
 603     putChr('\"');
 604     for (; *s; s++) {
 605         String ch = unlexChar(*s,'\"');
 606         Char   c  = ' ';
 607
 608         if ((lastWasSO && *ch=='H') ||
 609                 (lastWasEsc && lastWasDigit
 610                  && isascii((int)(*ch)) && isdigit((int)(*ch))))
 611             putStr("\\&");
 612
 613         lastWasEsc   = (*ch=='\\');
 614         lastWasSO    = (*s==SO);
 615         for (; *ch; c = *ch++)
 616             putChr(*ch);
 617         lastWasDigit = (isascii(c) && isdigit(c));
 618     }
 619     putChr('\"');
 620 }
 621
 622 /* --------------------------------------------------------------------------
 623  * Print type expression:
 624  * ------------------------------------------------------------------------*/
 625
 626 static Void local putSigType(t)         /* print (possibly) generic type   */
 627 Cell t; {
 628     Int fr = 0;
 629     if (isPolyType(t)) {
 630         Kinds ks = polySigOf(t);
 631         for (; isAp(ks); ks=tl(ks))
 632             fr++;
 633         t = monotypeOf(t);
 634     }
 635
 636     putType(t,NEVER,fr);                /* Finally, print rest of type ... */
 637 }
 638
 639 static Void local putContext(ps,qs,fr)  /* print context list              */
 640 List ps;
 641 List qs;
 642 Int  fr; {
 643     Int len = length(ps) + length(qs);
 644     Int c   = len;
 645 #if IPARAM
 646     Bool useParens = len!=1 || isIP(fun(hd(ps)));
 647 #else
 648     Bool useParens = len!=1;
 649 #endif
 650     if (useParens)
 651         putChr('(');
 652     for (; nonNull(ps); ps=tl(ps)) {
 653         putPred(hd(ps),fr);
 654         if (--c > 0) {
 655             putStr(", ");
 656         }
 657     }
 658     for (; nonNull(qs); qs=tl(qs)) {
 659         putPred(hd(qs),fr);
 660         if (--c > 0) {
 661             putStr(", ");
 662         }
 663     }
 664     if (useParens)
 665         putChr(')');
 666 }
 667
 668 static Void local putPred(pi,fr)        /* Output predicate                */
 669 Cell pi;
 670 Int  fr; {
 671     if (isAp(pi)) {
 672 #if TREX
 673         if (isExt(fun(pi))) {
 674             putType(arg(pi),ALWAYS,fr);
 675             putChr('\\');
 676             putStr(textToStr(extText(fun(pi))));
 677             return;
 678         }
 679 #endif
 680 #if IPARAM
 681         if (whatIs(fun(pi)) == IPCELL) {
 682             putChr('?');
 683             putPred(fun(pi),fr);
 684             putStr(" :: ");
 685             putType(arg(pi),NEVER,fr);
 686             return;
 687         }
 688 #endif
 689         putPred(fun(pi),fr);
 690         putChr(' ');
 691         putType(arg(pi),ALWAYS,fr);
 692     }
 693     else if (isClass(pi))
 694         putStr(textToStr(cclass(pi).text));
 695     else if (isCon(pi))
 696         putStr(textToStr(textOf(pi)));
 697 #if IPARAM
 698     else if (whatIs(pi) == IPCELL)
 699         unlexVar(textOf(pi));
 700 #endif
 701     else
 702         putStr("<unknownPredicate>");
 703 }
 704
 705 static Void local putType(t,prec,fr)    /* print nongeneric type expression*/
 706 Cell t;
 707 Int  prec;
 708 Int  fr; {
 709     switch(whatIs(t)) {
 710         case TYCON     : putStr(textToStr(tycon(t).text));
 711                          break;
 712
 713         case TUPLE     : {   Int n = tupleOf(t);
 714                              putChr('(');
 715                              while (--n > 0)
 716                                  putChr(',');
 717                              putChr(')');
 718                          }
 719                          break;
 720
 721         case POLYTYPE  : {   Kinds ks = polySigOf(t);
 722                              OPEN(prec>=ARROW_PREC);
 723                              putStr("forall ");
 724                              for (; isAp(ks); ks=tl(ks)) {
 725                                  putTyVar(fr++);
 726                                  if (isAp(tl(ks)))
 727                                      putChr(' ');
 728                              }
 729                              putStr(". ");
 730                              putType(monotypeOf(t),NEVER,fr);
 731                              CLOSE(prec>=ARROW_PREC);
 732                          }
 733                          break;
 734
 735         case CDICTS    :
 736         case QUAL      : OPEN(prec>=ARROW_PREC);
 737                          if (whatIs(snd(snd(t)))==CDICTS) {
 738                              putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
 739                              putStr(" => ");
 740                              putType(snd(snd(snd(snd(t)))),NEVER,fr);
 741                          } else {
 742                              putContext(fst(snd(t)),NIL,fr);
 743                              putStr(" => ");
 744                              putType(snd(snd(t)),NEVER,fr);
 745                          }
 746                          CLOSE(prec>=ARROW_PREC);
 747                          break;
 748
 749         case EXIST     :
 750         case RANK2     : putType(snd(snd(t)),prec,fr);
 751                          break;
 752
 753         case OFFSET    : putTyVar(offsetOf(t));
 754                          break;
 755
 756         case VARIDCELL :
 757         case VAROPCELL : putChr('_');
 758                          unlexVar(textOf(t));
 759                          break;
 760
 761         case INTCELL   : putChr('_');
 762                          putInt(intOf(t));
 763                          break;
 764
 765         case AP       : {   Cell typeHead = getHead(t);
 766                             Bool brackets = (argCount!=0 && prec>=ALWAYS);
 767                             Int  args    = argCount;
 768
 769                             if (typeHead==typeList) {
 770                                 if (argCount==1) {
 771                                     putChr('[');
 772                                     putType(arg(t),NEVER,fr);
 773                                     putChr(']');
 774                                     return;
 775                                 }
 776                             }
 777                             else if (typeHead==typeArrow) {
 778                                 if (argCount==2) {
 779                                     OPEN(prec>=ARROW_PREC);
 780                                     putType(arg(fun(t)),ARROW_PREC,fr);
 781                                     putStr(" -> ");
 782                                     putType(arg(t),NEVER,fr);
 783                                     CLOSE(prec>=ARROW_PREC);
 784                                     return;
 785                                 }
 786 #if 0
 787                                 else if (argCount==1) {
 788                                     putChr('(');
 789                                     putType(arg(t),ARROW_PREC,fr);
 790                                     putStr("->)");
 791                                     return;
 792                                 }
 793 #endif
 794                             }
 795                             else if (isTuple(typeHead)) {
 796                                 if (argCount==tupleOf(typeHead)) {
 797                                     putChr('(');
 798                                     putTupleType(t,fr);
 799                                     putChr(')');
 800                                     return;
 801                                 }
 802                             }
 803 #if TREX
 804                             else if (isExt(typeHead)) {
 805                                 if (args==2) {
 806                                     String punc = "(";
 807                                     do {
 808                                         putStr(punc);
 809                                         punc = ", ";
 810                                         putStr(textToStr(extText(typeHead)));
 811                                         putStr(" :: ");
 812                                         putType(extField(t),NEVER,fr);
 813                                         t        = extRow(t);
 814                                         typeHead = getHead(t);
 815                                     } while (isExt(typeHead) && argCount==2);
 816                                     if (t!=typeNoRow) {
 817                                         putStr(" | ");
 818                                         putType(t,NEVER,fr);
 819                                     }
 820                                     putChr(')');
 821                                     return;
 822                                 }
 823                                 else if (args<2)
 824                                     internal("putExt");
 825                                 else
 826                                     args-=2;
 827                             }
 828 #endif
 829                             OPEN(brackets);
 830                             putApType(t,args,fr);
 831                             CLOSE(brackets);
 832                         }
 833                         break;
 834
 835         default       : putStr("(bad type)");
 836     }
 837 }
 838
 839 static Void local putTyVar(n)           /* print type variable             */
 840 Int n; {
 841     static String alphabet              /* for the benefit of EBCDIC :-)   */
 842                 ="abcdefghijklmnopqrstuvwxyz";
 843     putChr(alphabet[n%26]);
 844     if (n /= 26)                        /* just in case there are > 26 vars*/
 845         putInt(n);
 846 }
 847
 848 static Bool local putTupleType(e,fr)    /* print tuple of types, returning */
 849 Cell e;                                 /* TRUE if something was printed,  */
 850 Int  fr; {                              /* FALSE otherwise; used to control*/
 851     if (isAp(e)) {                      /* printing of intermed. commas    */
 852         if (putTupleType(fun(e),fr))
 853             putChr(',');
 854         putType(arg(e),NEVER,fr);
 855         return TRUE;
 856     }
 857     return FALSE;
 858 }
 859
 860 static Void local putApType(t,n,fr)     /* print type application          */
 861 Cell t;
 862 Int  n;
 863 Int  fr; {
 864     if (n>0) {
 865         putApType(fun(t),n-1,fr);
 866         putChr(' ');
 867         putType(arg(t),ALWAYS,fr);
 868     }
 869     else
 870         putType(t,ALWAYS,fr);
 871 }
 872
 873 /* --------------------------------------------------------------------------
 874  * Print kind expression:
 875  * ------------------------------------------------------------------------*/
 876
 877 static Void local putKind(k)            /* print kind expression           */
 878 Kind k; {
 879     switch (whatIs(k)) {
 880         case AP      : if (isAp(fst(k))) {
 881                            putChr('(');
 882                            putKind(fst(k));
 883                            putChr(')');
 884                        }
 885                        else
 886                            putKind(fst(k));
 887                        putStr(" -> ");
 888                        putKind(snd(k));
 889                        break;
 890
 891 #if TREX
 892         case ROW     : putStr("row");
 893                        break;
 894 #endif
 895
 896         case STAR    : putChr('*');
 897                        break;
 898
 899         case OFFSET  : putTyVar(offsetOf(k));
 900                        break;
 901
 902         case INTCELL : putChr('_');
 903                        putInt(intOf(k));
 904                        break;
 905
 906         default      : putStr("(bad kind)");
 907     }
 908 }
 909
 910 static Void local putKinds(ks)          /* Print list of kinds             */
 911 Kinds ks; {
 912     if (isNull(ks))
 913         putStr("()");
 914     else if (nonNull(tl(ks))) {
 915         putChr('(');
 916         putKind(hd(ks));
 917         while (nonNull(ks=tl(ks))) {
 918             putChr(',');
 919             putKind(hd(ks));
 920         }
 921         putChr(')');
 922     }
 923     else
 924         putKind(hd(ks));
 925 }
 926
 927 /* --------------------------------------------------------------------------
 928  * Main drivers:
 929  * ------------------------------------------------------------------------*/
 930
 931 FILE *mystdout ( Void ) {
 932   /* We use this from the gdb command line when debugging */
 933   return stdout;
 934 }
 935
 936 Void printExp(fp,e)                     /* print expr on specified stream  */
 937 FILE *fp;
 938 Cell e; {
 939     outputStream = fp;
 940     putDepth     = 0;
 941     put(NEVER,e);
 942 }
 943
 944 Void printType(fp,t)                    /* print type on specified stream  */
 945 FILE *fp;
 946 Cell t; {
 947     outputStream = fp;
 948     putSigType(t);
 949 }
 950
 951 Void printContext(fp,qs)                /* print context on spec. stream   */
 952 FILE *fp;
 953 List qs; {
 954     outputStream = fp;
 955     putContext(qs,NIL,0);
 956 }
 957
 958 Void printPred(fp,pi)                   /* print predicate pi on stream    */
 959 FILE *fp;
 960 Cell pi; {
 961     outputStream = fp;
 962     putPred(pi,0);
 963 }
 964
 965 Void printKind(fp,k)                    /* print kind k on stream          */
 966 FILE *fp;
 967 Kind k; {
 968     outputStream = fp;
 969     putKind(k);
 970 }
 971
 972 Void printKinds(fp,ks)                  /* print list of kinds on stream   */
 973 FILE  *fp;
 974 Kinds ks; {
 975     outputStream = fp;
 976     putKinds(ks);
 977 }
 978
 979 Void printFD(fp,fd)                     /* print functional dependency     */
 980 FILE* fp;
 981 Pair  fd; {
 982     List us;
 983     outputStream = fp;
 984     for (us=fst(fd); nonNull(us); us=tl(us)) {
 985         putTyVar(offsetOf(hd(us)));
 986         if (nonNull(tl(us))) {
 987             putChr(' ');
 988         }
 989     }
 990     putStr(" -> ");
 991     for (us=snd(fd); nonNull(us); us=tl(us)) {
 992         putTyVar(offsetOf(hd(us)));
 993         if (nonNull(tl(us))) {
 994             putChr(' ');
 995         }
 996     }
 997 }
 998
 999 /*-------------------------------------------------------------------------*/