1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
3 * Unparse expressions and types - for use in error messages, type checker
6 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
7 * All rights reserved. See NOTICE for details and conditions of use etc...
8 * Hugs version 1.4, December 1997
10 * $RCSfile: output.c,v $
12 * $Date: 1998/12/02 13:22:24 $
13 * ------------------------------------------------------------------------*/
18 #include "input.h" /* for textPlus */
23 #define DEPTH_LIMIT 15
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
29 static Void local putChr Args((Int));
30 static Void local putStr Args((String));
31 static Void local putInt Args((Int));
33 static Void local put Args((Int,Cell));
34 static Void local putFlds Args((Cell,List));
35 static Void local putComp Args((Cell,List));
36 static Void local putQual Args((Cell));
37 static Bool local isDictVal Args((Cell));
38 static Cell local maySkipDict Args((Cell));
39 static Void local putAp Args((Int,Cell));
40 static Void local putOverInfix Args((Int,Text,Syntax,Cell));
41 static Void local putInfix Args((Int,Text,Syntax,Cell,Cell));
42 static Void local putSimpleAp Args((Cell,Int));
43 static Void local putTuple Args((Int,Cell));
44 static Int local unusedTups Args((Int,Cell));
45 static Void local unlexVar Args((Text));
46 static Void local unlexOp Args((Text));
47 static Void local unlexCharConst Args((Cell));
48 static Void local unlexStrConst Args((Text));
50 static Void local putSigType Args((Cell));
51 static Void local putContext Args((List,Int));
52 static Void local putPred Args((Cell,Int));
53 static Void local putType Args((Cell,Int,Int));
54 static Void local putTyVar Args((Int));
55 static Bool local putTupleType Args((Cell,Int));
56 static Void local putApType Args((Type,Int,Int));
58 static Void local putKind Args((Kind));
59 static Void local putKinds Args((Kinds));
61 /* --------------------------------------------------------------------------
62 * Basic output routines:
63 * ------------------------------------------------------------------------*/
65 static FILE *outputStream; /* current output stream */
67 #define OPEN(b) if (b) putChr('(');
68 #define CLOSE(b) if (b) putChr(')');
70 static Void local putChr(c) /* print single character */
75 static Void local putStr(s) /* print string */
78 Putc(*s,outputStream);
82 static Void local putInt(n) /* print integer */
84 static char intBuf[16];
85 sprintf(intBuf,"%d",n);
89 /* --------------------------------------------------------------------------
90 * Precedence values (See Haskell 1.3 report, p.12):
91 * ------------------------------------------------------------------------*/
93 #define ALWAYS FUN_PREC /* Always use parens (unless atomic)*/
94 /* User defined operators have prec */
95 /* in the range MIN_PREC..MAX_PREC */
96 #define ARROW_PREC MAX_PREC /* for printing -> in type exprs */
97 #define COCO_PREC (MIN_PREC-1) /* :: is left assoc, low precedence */
98 #define COND_PREC (MIN_PREC-2) /* conditional expressions */
99 #define WHERE_PREC (MIN_PREC-3) /* where expressions */
100 #define LAM_PREC (MIN_PREC-4) /* lambda abstraction */
101 #define NEVER LAM_PREC /* Never use parentheses */
104 /* --------------------------------------------------------------------------
105 * Print an expression (used to display context of type errors):
106 * ------------------------------------------------------------------------*/
108 static Int putDepth = 0; /* limits depth of printing DBG */
110 static Void local put(d,e) /* print expression e in context of */
111 Int d; /* operator of precedence d */
115 if (putDepth>DEPTH_LIMIT) {
123 case FINLIST : putChr('[');
127 while (nonNull(xs=tl(xs))) {
135 case AP : putAp(d,e);
138 case NAME : unlexVar(name(e).text);
145 case CONOPCELL : unlexVar(textOf(e));
149 case RECSEL : putChr('#');
150 unlexVar(extText(snd(e)));
154 case FREECELL : putStr("{free!}");
157 case TUPLE : putTuple(tupleOf(e),e);
160 case WILDCARD : putChr('_');
163 case ASPAT : put(NEVER,fst(snd(e)));
165 put(ALWAYS,snd(snd(e)));
168 case LAZYPAT : putChr('~');
172 case DOCOMP : putStr("do {...}");
175 case COMP : putComp(fst(snd(e)),snd(snd(e)));
178 case CHARCELL : unlexCharConst(charOf(e));
181 case INTCELL : putInt(intOf(e));
184 case BIGCELL : putStr(bignumToString(e));
187 case FLOATCELL : putStr(floatToString(e));
190 case STRCELL : unlexStrConst(textOf(e));
193 case LETREC : OPEN(d>WHERE_PREC);
196 put(NEVER,fst(snd(e)));
199 putStr("let {...} in ");
201 put(WHERE_PREC+1,snd(snd(e)));
205 case COND : OPEN(d>COND_PREC);
207 put(COND_PREC+1,fst3(snd(e)));
209 put(COND_PREC+1,snd3(snd(e)));
211 put(COND_PREC+1,thd3(snd(e)));
215 case LAMBDA : xs = fst(snd(e));
216 if (whatIs(xs)==BIGLAM)
218 while (nonNull(xs) && isDictVal(hd(xs)))
221 put(d,snd(snd(snd(e))));
228 while (nonNull(xs=tl(xs))) {
234 put(LAM_PREC,snd(snd(snd(e))));
238 case ESIGN : OPEN(d>COCO_PREC);
239 put(COCO_PREC,fst(snd(e)));
241 putSigType(snd(snd(e)));
245 case BIGLAM : put(d,snd(snd(e)));
248 case CASE : putStr("case ");
249 put(NEVER,fst(snd(e)));
252 put(NEVER,snd(snd(e)));
259 case CONFLDS : putFlds(fst(snd(e)),snd(snd(e)));
262 case UPDFLDS : putFlds(fst3(snd(e)),thd3(snd(e)));
265 default : /*internal("put");*/
273 static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
278 for (; nonNull(fs); fs=tl(fs)) {
285 Text t = isName(f) ? name(f).text :
286 isVar(f) ? textOf(f) : inventText();
287 Text s = isName(e) ? name(e).text :
288 isVar(e) ? textOf(e) : inventText();
302 static Void local putComp(e,qs) /* print comprehension */
310 while (nonNull(qs=tl(qs))) {
318 static Void local putQual(q) /* print list comp qualifier */
321 case BOOLQUAL : put(NEVER,snd(q));
324 case QWHERE : putStr("let {...}");
327 case FROMQUAL : put(ALWAYS,fst(snd(q)));
329 put(NEVER,snd(snd(q)));
334 static Bool local isDictVal(e) /* Look for dictionary value */
339 case DICTVAR : return TRUE;
340 case NAME : return isDfun(h);
346 static Cell local maySkipDict(e) /* descend function application, */
347 Cell e; { /* ignoring dict aps */
348 while (isAp(e) && isDictVal(arg(e)))
353 static Void local putAp(d,e) /* print application (args>=1) */
361 for (h=e; isAp(h); h=fun(h)) /* find head of expression, looking*/
362 if (!isDictVal(arg(h))) /* for dictionary arguments */
365 if (args==0) { /* Special case when *all* args */
366 put(d,h); /* are dictionary values */
372 case ADDPAT : if (args==1)
373 putInfix(d,textPlus,syntaxOf(textPlus),
380 case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
381 putTuple(tupleOf(h),e);
382 CLOSE(args>tupleOf(h) && d>=FUN_PREC);
385 case NAME : if (args==1 &&
386 ((h==nameFromInt && isInt(arg(e))) ||
387 (h==nameFromInteger && isBignum(arg(e))) ||
388 (h==nameFromDouble && isFloat(arg(e))))) {
392 sy = syntaxOf(t = name(h).text);
399 case CONOPCELL : sy = syntaxOf(t = textOf(h));
403 case EXT : if (args==2) {
408 putStr(textToStr(extText(h)));
410 put(NEVER,extField(e));
413 for (h=e; isAp(h); h=fun(h))
414 if (!isDictVal(arg(h)))
416 } while (isExt(h) && args==2);
431 default : sy = APPLIC;
437 if (sy==APPLIC) { /* print simple application */
443 else if (args==1) { /* print section of the form (e+) */
445 put(FUN_PREC-1,arg(e));
450 else if (args==2) /* infix expr of the form e1 + e2 */
451 putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
452 else { /* o/w (e1 + e2) e3 ... en (n>=3) */
454 putOverInfix(args,t,sy,e);
459 static Void local putOverInfix(args,t,sy,e)
460 Int args; /* infix applied to >= 3 arguments */
465 putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
467 put(FUN_PREC,arg(e));
470 putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
473 static Void local putInfix(d,t,sy,e,f) /* print infix expression */
475 Text t; /* Infix operator symbol */
476 Syntax sy; /* with name t, syntax s */
477 Cell e, f; { /* Left and right operands */
478 Syntax a = assocOf(sy);
482 put((a==LEFT_ASS ? p : 1+p), e);
486 put((a==RIGHT_ASS ? p : 1+p), f);
490 static Void local putSimpleAp(e,n) /* print application e0 e1 ... en */
494 putSimpleAp(maySkipDict(fun(e)),n-1);
496 put(FUN_PREC,arg(e));
502 static Void local putTuple(ts,e) /* Print tuple expression, allowing*/
503 Int ts; /* for possibility of either too */
504 Cell e; { /* few or too many args to constr */
507 if ((i=unusedTups(ts,e))>0) {
514 static Int local unusedTups(ts,e) /* print first part of tuple expr */
515 Int ts; /* returning number of constructor */
516 Cell e; { /* args not yet printed ... */
518 if ((ts=unusedTups(ts,fun(e))-1)>=0) {
520 putChr(ts>0?',':')');
524 put(FUN_PREC,arg(e));
530 static Void local unlexVar(t) /* print text as a variable name */
531 Text t; { /* operator symbols must be enclosed*/
532 String s = textToStr(t); /* in parentheses... except [] ... */
534 if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
543 static Void local unlexOp(t) /* print text as operator name */
544 Text t; { /* alpha numeric symbols must be */
545 String s = textToStr(t); /* enclosed by backquotes */
547 if (isascii(s[0]) && isalpha(s[0])) {
556 static Void local unlexCharConst(c)
559 putStr(unlexChar(c,'\''));
563 static Void local unlexStrConst(t)
565 String s = textToStr(t);
566 static Char SO = 14; /* ASCII code for '\SO' */
567 Bool lastWasSO = FALSE;
568 Bool lastWasDigit = FALSE;
569 Bool lastWasEsc = FALSE;
573 String ch = unlexChar(*s,'\"');
576 if ((lastWasSO && *ch=='H') ||
577 (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
580 lastWasEsc = (*ch=='\\');
581 lastWasSO = (*s==SO);
582 for (; *ch; c = *ch++)
584 lastWasDigit = (isascii(c) && isdigit(c));
589 /* --------------------------------------------------------------------------
590 * Print type expression:
591 * ------------------------------------------------------------------------*/
593 static Void local putSigType(t) /* print (possibly) generic type */
597 Kinds ks = polySigOf(t);
598 for (; isAp(ks); ks=tl(ks))
603 putType(t,NEVER,fr); /* Finally, print rest of type ... */
606 static Void local putContext(qs,fr) /* print context list */
613 if (nq!=1) putChr('(');
615 while (nonNull(qs=tl(qs))) {
619 if (nq!=1) putChr(')');
623 static Void local putPred(pi,fr) /* Output predicate */
628 if (isExt(fun(pi))) {
629 putType(arg(pi),ALWAYS,fr);
631 putStr(textToStr(extText(fun(pi))));
637 putType(arg(pi),ALWAYS,fr);
639 else if (isClass(pi))
640 putStr(textToStr(cclass(pi).text));
642 putStr(textToStr(textOf(pi)));
644 putStr("<unknownPredicate>");
647 static Void local putType(t,prec,fr) /* print nongeneric type expression*/
652 case TYCON : putStr(textToStr(tycon(t).text));
655 case TUPLE : { Int n = tupleOf(t);
663 case POLYTYPE : { Kinds ks = polySigOf(t);
664 OPEN(prec>=ARROW_PREC);
666 for (; isAp(ks); ks=tl(ks)) {
672 putType(monotypeOf(t),NEVER,fr);
673 CLOSE(prec>=ARROW_PREC);
677 case QUAL : OPEN(prec>=ARROW_PREC);
678 putContext(fst(snd(t)),fr);
680 putType(snd(snd(t)),NEVER,fr);
681 CLOSE(prec>=ARROW_PREC);
685 case RANK2 : putType(snd(snd(t)),prec,fr);
688 case OFFSET : putTyVar(offsetOf(t));
692 case VAROPCELL : putChr('_');
696 case INTCELL : putChr('_');
700 /* #ifdef DEBUG_TYPES */
701 case STAR : putChr('*');
705 case AP : { Cell typeHead = getHead(t);
706 Bool brackets = (argCount!=0 && prec>=ALWAYS);
709 if (typeHead==typeList) {
712 putType(arg(t),NEVER,fr);
717 else if (typeHead==typeArrow) {
719 OPEN(prec>=ARROW_PREC);
720 putType(arg(fun(t)),ARROW_PREC,fr);
722 putType(arg(t),NEVER,fr);
723 CLOSE(prec>=ARROW_PREC);
726 else if (argCount==1) {
728 putType(arg(t),ARROW_PREC,fr);
733 else if (isTuple(typeHead)) {
734 if (argCount==tupleOf(typeHead)) {
742 else if (isExt(typeHead)) {
748 putStr(textToStr(extText(typeHead)));
750 putType(extField(t),NEVER,fr);
752 typeHead = getHead(t);
753 } while (isExt(typeHead) && argCount==2);
768 putApType(t,args,fr);
773 default : putStr("(bad type)");
777 static Void local putTyVar(n) /* print type variable */
779 static String alphabet /* for the benefit of EBCDIC :-) */
780 ="abcdefghijklmnopqrstuvwxyz";
781 putChr(alphabet[n%26]);
782 if (n /= 26) /* just in case there are > 26 vars*/
786 static Bool local putTupleType(e,fr) /* print tuple of types, returning */
787 Cell e; /* TRUE if something was printed, */
788 Int fr; { /* FALSE otherwise; used to control*/
789 if (isAp(e)) { /* printing of intermed. commas */
790 if (putTupleType(fun(e),fr))
792 putType(arg(e),NEVER,fr);
798 static Void local putApType(t,n,fr) /* print type application */
803 putApType(fun(t),n-1,fr);
805 putType(arg(t),ALWAYS,fr);
808 putType(t,ALWAYS,fr);
811 /* --------------------------------------------------------------------------
812 * Print kind expression:
813 * ------------------------------------------------------------------------*/
815 static Void local putKind(k) /* print kind expression */
818 case AP : if (isAp(fst(k))) {
830 case ROW : putStr("row");
834 case STAR : putChr('*');
837 case OFFSET : putTyVar(offsetOf(k));
840 case INTCELL : putChr('_');
844 default : putStr("(bad kind)");
848 static Void local putKinds(ks) /* Print list of kinds */
852 else if (nonNull(tl(ks))) {
855 while (nonNull(ks=tl(ks))) {
865 /* --------------------------------------------------------------------------
867 * ------------------------------------------------------------------------*/
869 Void printExp(fp,e) /* print expr on specified stream */
877 Void printType(fp,t) /* print type on specified stream */
884 Void printContext(fp,qs) /* print context on spec. stream */
891 Void printPred(fp,pi) /* print predicate pi on stream */
898 Void printKind(fp,k) /* print kind k on stream */
905 Void printKinds(fp,ks) /* print list of kinds on stream */
912 /*-------------------------------------------------------------------------*/