2 /* --------------------------------------------------------------------------
3 * Unparse expressions and types - for use in error messages, type checker
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.
12 * $RCSfile: output.c,v $
14 * $Date: 2000/03/23 14:54:21 $
15 * ------------------------------------------------------------------------*/
17 #include "hugsbasictypes.h"
23 #define DEPTH_LIMIT 15
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
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 );
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 );
51 static Void local putKind ( Kind );
52 static Void local putKinds ( Kinds );
55 /* --------------------------------------------------------------------------
56 * Basic output routines:
57 * ------------------------------------------------------------------------*/
59 FILE *outputStream; /* current output stream */
60 Int outColumn = 0; /* current output column number */
62 #define OPEN(b) if (b) putChr('(');
63 #define CLOSE(b) if (b) putChr(')');
65 Void putChr(c) /* print single character */
71 Void putStr(s) /* print string */
74 Putc(*s,outputStream);
79 Void putInt(n) /* print integer */
81 static char intBuf[16];
82 sprintf(intBuf,"%d",n);
86 Void putPtr(p) /* print pointer */
88 static char intBuf[16];
89 sprintf(intBuf,"%p",p);
93 /* --------------------------------------------------------------------------
94 * Precedence values (See Haskell 1.3 report, p.12):
95 * ------------------------------------------------------------------------*/
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 */
108 /* --------------------------------------------------------------------------
109 * Print an expression (used to display context of type errors):
110 * ------------------------------------------------------------------------*/
112 static Int putDepth = 0; /* limits depth of printing DBG */
114 static Void local put(d,e) /* print expression e in context of */
115 Int d; /* operator of precedence d */
119 if (putDepth>DEPTH_LIMIT) {
127 case FINLIST : putChr('[');
131 while (nonNull(xs=tl(xs))) {
139 case AP : putAp(d,e);
142 case NAME : unlexVar(name(e).text);
149 case CONOPCELL : unlexVar(textOf(e));
153 case IPVAR : putChr('?');
157 case WITHEXP : OPEN(d>WHERE_PREC);
158 putStr("dlet {...} in ");
159 put(WHERE_PREC+1,fst(snd(e)));
165 case RECSEL : putChr('#');
166 unlexVar(extText(snd(e)));
170 case FREECELL : putStr("{free!}");
173 case TUPLE : putTuple(tupleOf(e),e);
176 case WILDCARD : putChr('_');
179 case ASPAT : put(NEVER,fst(snd(e)));
181 put(ALWAYS,snd(snd(e)));
184 case LAZYPAT : putChr('~');
188 case DOCOMP : putStr("do {...}");
191 case COMP : putComp(fst(snd(e)),snd(snd(e)));
194 case MONADCOMP : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
197 case CHARCELL : unlexCharConst(charOf(e));
200 case INTCELL : { Int i = intOf(e);
201 if (i<0 && d>=UMINUS_PREC) putChr('(');
203 if (i<0 && d>=UMINUS_PREC) putChr(')');
207 case FLOATCELL : { Float f = floatOf(e);
208 if (f<0 && d>=UMINUS_PREC) putChr('(');
209 putStr(floatToString(e));
210 if (f<0 && d>=UMINUS_PREC) putChr(')');
214 case STRCELL : unlexStrConst(textOf(e));
217 case LETREC : OPEN(d>WHERE_PREC);
220 put(NEVER,fst(snd(e)));
223 putStr("let {...} in ");
225 put(WHERE_PREC+1,snd(snd(e)));
229 case COND : OPEN(d>COND_PREC);
231 put(COND_PREC+1,fst3(snd(e)));
233 put(COND_PREC+1,snd3(snd(e)));
235 put(COND_PREC+1,thd3(snd(e)));
239 case LAMBDA : xs = fst(snd(e));
240 if (whatIs(xs)==BIGLAM)
242 while (nonNull(xs) && isDictVal(hd(xs)))
245 put(d,snd(snd(snd(e))));
252 while (nonNull(xs=tl(xs))) {
258 put(LAM_PREC,snd(snd(snd(e))));
262 case ESIGN : OPEN(d>COCO_PREC);
263 put(COCO_PREC,fst(snd(e)));
265 putSigType(snd(snd(e)));
269 case BIGLAM : put(d,snd(snd(e)));
272 case CASE : putStr("case ");
273 put(NEVER,fst(snd(e)));
276 put(NEVER,snd(snd(e)));
283 case CONFLDS : putFlds(fst(snd(e)),snd(snd(e)));
286 case UPDFLDS : putFlds(fst3(snd(e)),thd3(snd(e)));
289 default : /*internal("put");*/
297 static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
302 for (; nonNull(fs); fs=tl(fs)) {
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();
315 if (haskell98 || s!=t) {
326 static Void local putComp(e,qs) /* print comprehension */
334 while (nonNull(qs=tl(qs))) {
342 static Void local putQual(q) /* print list comp qualifier */
345 case BOOLQUAL : put(NEVER,snd(q));
348 case QWHERE : putStr("let {...}");
351 case FROMQUAL : put(ALWAYS,fst(snd(q)));
353 put(NEVER,snd(snd(q)));
358 static Bool local isDictVal(e) /* Look for dictionary value */
360 #if 0 /* was !DEBUG_CODE -- is it necessary? */
363 case DICTVAR : return TRUE;
364 case NAME : return isDfun(h);
370 static Cell local maySkipDict(e) /* descend function application, */
371 Cell e; { /* ignoring dict aps */
372 while (isAp(e) && isDictVal(arg(e)))
377 static Void local putAp(d,e) /* print application (args>=1) */
381 Text t = 0; /* bogus init to keep gcc -O happy */
385 for (h=e; isAp(h); h=fun(h)) /* find head of expression, looking*/
386 if (!isDictVal(arg(h))) /* for dictionary arguments */
389 if (args==0) { /* Special case when *all* args */
390 put(d,h); /* are dictionary values */
395 case ADDPAT : if (args==1)
396 putInfix(d,textPlus,syntaxOf(namePlus),
397 arg(e),mkInt(intValOf(fun(e))));
402 case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
403 putTuple(tupleOf(h),e);
404 CLOSE(args>tupleOf(h) && d>=FUN_PREC);
407 case NAME : if (args==1 &&
408 ((h==nameFromInt && isInt(arg(e))) ||
409 (h==nameFromDouble && isFloat(arg(e))))) {
421 case CONOPCELL : sy = defaultSyntax(t = textOf(h));
425 case EXT : if (args==2) {
430 putStr(textToStr(extText(h)));
432 put(NEVER,extField(e));
435 for (h=e; isAp(h); h=fun(h))
436 if (!isDictVal(arg(h)))
438 } while (isExt(h) && args==2);
453 default : sy = APPLIC;
459 if (sy==APPLIC) { /* print simple application */
465 else if (args==1) { /* print section of the form (e+) */
467 put(FUN_PREC-1,arg(e));
472 else if (args==2) /* infix expr of the form e1 + e2 */
473 putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
474 else { /* o/w (e1 + e2) e3 ... en (n>=3) */
476 putOverInfix(args,t,sy,e);
481 static Void local putOverInfix(args,t,sy,e)
482 Int args; /* infix applied to >= 3 arguments */
487 putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
489 put(FUN_PREC,arg(e));
492 putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
495 static Void local putInfix(d,t,sy,e,f) /* print infix expression */
497 Text t; /* Infix operator symbol */
498 Syntax sy; /* with name t, syntax s */
499 Cell e, f; { /* Left and right operands */
500 Syntax a = assocOf(sy);
504 put((a==LEFT_ASS ? p : 1+p), e);
508 put((a==RIGHT_ASS ? p : 1+p), f);
512 static Void local putSimpleAp(e,n) /* print application e0 e1 ... en */
516 putSimpleAp(maySkipDict(fun(e)),n-1);
518 put(FUN_PREC,arg(e));
524 static Void local putTuple(ts,e) /* Print tuple expression, allowing*/
525 Int ts; /* for possibility of either too */
526 Cell e; { /* few or too many args to constr */
529 if ((i=unusedTups(ts,e))>0) {
536 static Int local unusedTups(ts,e) /* print first part of tuple expr */
537 Int ts; /* returning number of constructor */
538 Cell e; { /* args not yet printed ... */
540 if ((ts=unusedTups(ts,fun(e))-1)>=0) {
542 putChr(ts>0?',':')');
546 put(FUN_PREC,arg(e));
554 if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
555 || s[0]=='_' || s[0]=='[' || s[0]=='('
557 || (s[0]==':' && s[1]=='D')
567 Void unlexVar(t) /* print text as a variable name */
568 Text t; { /* operator symbols must be enclosed*/
569 unlexVarStr(textToStr(t)); /* in parentheses... except [] ... */
572 static Void local unlexOp(t) /* print text as operator name */
573 Text t; { /* alpha numeric symbols must be */
574 String s = textToStr(t); /* enclosed by backquotes */
576 if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
585 Void unlexCharConst(c)
588 putStr(unlexChar(c,'\''));
592 Void unlexStrConst(t)
594 String s = textToStr(t);
595 static Char SO = 14; /* ASCII code for '\SO' */
596 Bool lastWasSO = FALSE;
597 Bool lastWasDigit = FALSE;
598 Bool lastWasEsc = FALSE;
602 String ch = unlexChar(*s,'\"');
605 if ((lastWasSO && *ch=='H') ||
606 (lastWasEsc && lastWasDigit
607 && isascii((int)(*ch)) && isdigit((int)(*ch))))
610 lastWasEsc = (*ch=='\\');
611 lastWasSO = (*s==SO);
612 for (; *ch; c = *ch++)
614 lastWasDigit = (isascii(c) && isdigit(c));
619 /* --------------------------------------------------------------------------
620 * Print type expression:
621 * ------------------------------------------------------------------------*/
623 static Void local putSigType(t) /* print (possibly) generic type */
627 Kinds ks = polySigOf(t);
628 for (; isAp(ks); ks=tl(ks))
633 putType(t,NEVER,fr); /* Finally, print rest of type ... */
636 static Void local putContext(ps,qs,fr) /* print context list */
640 Int len = length(ps) + length(qs);
643 Bool useParens = len!=1 || isIP(fun(hd(ps)));
645 Bool useParens = len!=1;
649 for (; nonNull(ps); ps=tl(ps)) {
655 for (; nonNull(qs); qs=tl(qs)) {
665 static Void local putPred(pi,fr) /* Output predicate */
670 if (isExt(fun(pi))) {
671 putType(arg(pi),ALWAYS,fr);
673 putStr(textToStr(extText(fun(pi))));
678 if (whatIs(fun(pi)) == IPCELL) {
682 putType(arg(pi),NEVER,fr);
688 putType(arg(pi),ALWAYS,fr);
690 else if (isClass(pi))
691 putStr(textToStr(cclass(pi).text));
693 putStr(textToStr(textOf(pi)));
695 else if (whatIs(pi) == IPCELL)
696 unlexVar(textOf(pi));
699 putStr("<unknownPredicate>");
702 static Void local putType(t,prec,fr) /* print nongeneric type expression*/
707 case TYCON : putStr(textToStr(tycon(t).text));
710 case TUPLE : { Int n = tupleOf(t);
718 case POLYTYPE : { Kinds ks = polySigOf(t);
719 OPEN(prec>=ARROW_PREC);
721 for (; isAp(ks); ks=tl(ks)) {
727 putType(monotypeOf(t),NEVER,fr);
728 CLOSE(prec>=ARROW_PREC);
733 case QUAL : OPEN(prec>=ARROW_PREC);
734 if (whatIs(snd(snd(t)))==CDICTS) {
735 putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
737 putType(snd(snd(snd(snd(t)))),NEVER,fr);
739 putContext(fst(snd(t)),NIL,fr);
741 putType(snd(snd(t)),NEVER,fr);
743 CLOSE(prec>=ARROW_PREC);
747 case RANK2 : putType(snd(snd(t)),prec,fr);
750 case OFFSET : putTyVar(offsetOf(t));
754 case VAROPCELL : putChr('_');
758 case INTCELL : putChr('_');
762 case AP : { Cell typeHead = getHead(t);
763 Bool brackets = (argCount!=0 && prec>=ALWAYS);
766 if (typeHead==typeList) {
769 putType(arg(t),NEVER,fr);
774 else if (typeHead==typeArrow) {
776 OPEN(prec>=ARROW_PREC);
777 putType(arg(fun(t)),ARROW_PREC,fr);
779 putType(arg(t),NEVER,fr);
780 CLOSE(prec>=ARROW_PREC);
784 else if (argCount==1) {
786 putType(arg(t),ARROW_PREC,fr);
792 else if (isTuple(typeHead)) {
793 if (argCount==tupleOf(typeHead)) {
801 else if (isExt(typeHead)) {
807 putStr(textToStr(extText(typeHead)));
809 putType(extField(t),NEVER,fr);
811 typeHead = getHead(t);
812 } while (isExt(typeHead) && argCount==2);
827 putApType(t,args,fr);
832 default : putStr("(bad type)");
836 static Void local putTyVar(n) /* print type variable */
838 static String alphabet /* for the benefit of EBCDIC :-) */
839 ="abcdefghijklmnopqrstuvwxyz";
840 putChr(alphabet[n%26]);
841 if (n /= 26) /* just in case there are > 26 vars*/
845 static Bool local putTupleType(e,fr) /* print tuple of types, returning */
846 Cell e; /* TRUE if something was printed, */
847 Int fr; { /* FALSE otherwise; used to control*/
848 if (isAp(e)) { /* printing of intermed. commas */
849 if (putTupleType(fun(e),fr))
851 putType(arg(e),NEVER,fr);
857 static Void local putApType(t,n,fr) /* print type application */
862 putApType(fun(t),n-1,fr);
864 putType(arg(t),ALWAYS,fr);
867 putType(t,ALWAYS,fr);
870 /* --------------------------------------------------------------------------
871 * Print kind expression:
872 * ------------------------------------------------------------------------*/
874 static Void local putKind(k) /* print kind expression */
877 case AP : if (isAp(fst(k))) {
889 case ROW : putStr("row");
893 case STAR : putChr('*');
896 case OFFSET : putTyVar(offsetOf(k));
899 case INTCELL : putChr('_');
903 default : putStr("(bad kind)");
907 static Void local putKinds(ks) /* Print list of kinds */
911 else if (nonNull(tl(ks))) {
914 while (nonNull(ks=tl(ks))) {
924 /* --------------------------------------------------------------------------
926 * ------------------------------------------------------------------------*/
928 FILE *mystdout ( Void ) {
929 /* We use this from the gdb command line when debugging */
933 Void printExp(fp,e) /* print expr on specified stream */
941 Void printType(fp,t) /* print type on specified stream */
948 Void printContext(fp,qs) /* print context on spec. stream */
952 putContext(qs,NIL,0);
955 Void printPred(fp,pi) /* print predicate pi on stream */
962 Void printKind(fp,k) /* print kind k on stream */
969 Void printKinds(fp,ks) /* print list of kinds on stream */
976 Void printFD(fp,fd) /* print functional dependency */
981 for (us=fst(fd); nonNull(us); us=tl(us)) {
982 putTyVar(offsetOf(hd(us)));
983 if (nonNull(tl(us))) {
988 for (us=snd(fd); nonNull(us); us=tl(us)) {
989 putTyVar(offsetOf(hd(us)));
990 if (nonNull(tl(us))) {
996 /*-------------------------------------------------------------------------*/