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: 1999/10/15 21:40:53 $
15 * ------------------------------------------------------------------------*/
23 #define DEPTH_LIMIT 15
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
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));
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));
51 static Void local putKind Args((Kind));
52 static Void local putKinds Args((Kinds));
54 /* --------------------------------------------------------------------------
55 * Basic output routines:
56 * ------------------------------------------------------------------------*/
58 FILE *outputStream; /* current output stream */
59 Int outColumn = 0; /* current output column number */
61 #define OPEN(b) if (b) putChr('(');
62 #define CLOSE(b) if (b) putChr(')');
64 Void putChr(c) /* print single character */
70 Void putStr(s) /* print string */
73 Putc(*s,outputStream);
78 Void putInt(n) /* print integer */
80 static char intBuf[16];
81 sprintf(intBuf,"%d",n);
85 Void putPtr(p) /* print pointer */
87 static char intBuf[16];
88 sprintf(intBuf,"%p",p);
92 /* --------------------------------------------------------------------------
93 * Precedence values (See Haskell 1.3 report, p.12):
94 * ------------------------------------------------------------------------*/
96 #define ALWAYS FUN_PREC /* Always use parens (unless atomic)*/
97 /* User defined operators have prec */
98 /* in the range MIN_PREC..MAX_PREC */
99 #define ARROW_PREC MAX_PREC /* for printing -> in type exprs */
100 #define COCO_PREC (MIN_PREC-1) /* :: is left assoc, low precedence */
101 #define COND_PREC (MIN_PREC-2) /* conditional expressions */
102 #define WHERE_PREC (MIN_PREC-3) /* where expressions */
103 #define LAM_PREC (MIN_PREC-4) /* lambda abstraction */
104 #define NEVER LAM_PREC /* Never use parentheses */
107 /* --------------------------------------------------------------------------
108 * Print an expression (used to display context of type errors):
109 * ------------------------------------------------------------------------*/
111 static Int putDepth = 0; /* limits depth of printing DBG */
113 static Void local put(d,e) /* print expression e in context of */
114 Int d; /* operator of precedence d */
118 if (putDepth>DEPTH_LIMIT) {
126 case FINLIST : putChr('[');
130 while (nonNull(xs=tl(xs))) {
138 case AP : putAp(d,e);
141 case NAME : unlexVar(name(e).text);
148 case CONOPCELL : unlexVar(textOf(e));
152 case RECSEL : putChr('#');
153 unlexVar(extText(snd(e)));
157 case FREECELL : putStr("{free!}");
160 case TUPLE : putTuple(tupleOf(e),e);
163 case WILDCARD : putChr('_');
166 case ASPAT : put(NEVER,fst(snd(e)));
168 put(ALWAYS,snd(snd(e)));
171 case LAZYPAT : putChr('~');
175 case DOCOMP : putStr("do {...}");
178 case COMP : putComp(fst(snd(e)),snd(snd(e)));
181 case MONADCOMP : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
184 case CHARCELL : unlexCharConst(charOf(e));
187 case INTCELL : { Int i = intOf(e);
188 if (i<0 && d>=UMINUS_PREC) putChr('(');
190 if (i<0 && d>=UMINUS_PREC) putChr(')');
194 case FLOATCELL : { Float f = floatOf(e);
195 if (f<0 && d>=UMINUS_PREC) putChr('(');
196 putStr(floatToString(f));
197 if (f<0 && d>=UMINUS_PREC) putChr(')');
201 case STRCELL : unlexStrConst(textOf(e));
204 case LETREC : OPEN(d>WHERE_PREC);
207 put(NEVER,fst(snd(e)));
210 putStr("let {...} in ");
212 put(WHERE_PREC+1,snd(snd(e)));
216 case COND : OPEN(d>COND_PREC);
218 put(COND_PREC+1,fst3(snd(e)));
220 put(COND_PREC+1,snd3(snd(e)));
222 put(COND_PREC+1,thd3(snd(e)));
226 case LAMBDA : xs = fst(snd(e));
227 if (whatIs(xs)==BIGLAM)
229 while (nonNull(xs) && isDictVal(hd(xs)))
232 put(d,snd(snd(snd(e))));
239 while (nonNull(xs=tl(xs))) {
245 put(LAM_PREC,snd(snd(snd(e))));
249 case ESIGN : OPEN(d>COCO_PREC);
250 put(COCO_PREC,fst(snd(e)));
252 putSigType(snd(snd(e)));
256 case BIGLAM : put(d,snd(snd(e)));
259 case CASE : putStr("case ");
260 put(NEVER,fst(snd(e)));
263 put(NEVER,snd(snd(e)));
270 case CONFLDS : putFlds(fst(snd(e)),snd(snd(e)));
273 case UPDFLDS : putFlds(fst3(snd(e)),thd3(snd(e)));
276 default : /*internal("put");*/
284 static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
289 for (; nonNull(fs); fs=tl(fs)) {
296 Text t = isName(f) ? name(f).text :
297 isVar(f) ? textOf(f) : inventText();
298 Text s = isName(e) ? name(e).text :
299 isVar(e) ? textOf(e) : inventText();
302 if (haskell98 || s!=t) {
313 static Void local putComp(e,qs) /* print comprehension */
321 while (nonNull(qs=tl(qs))) {
329 static Void local putQual(q) /* print list comp qualifier */
332 case BOOLQUAL : put(NEVER,snd(q));
335 case QWHERE : putStr("let {...}");
338 case FROMQUAL : put(ALWAYS,fst(snd(q)));
340 put(NEVER,snd(snd(q)));
345 static Bool local isDictVal(e) /* Look for dictionary value */
350 case DICTVAR : return TRUE;
351 case NAME : return isDfun(h);
357 static Cell local maySkipDict(e) /* descend function application, */
358 Cell e; { /* ignoring dict aps */
359 while (isAp(e) && isDictVal(arg(e)))
364 static Void local putAp(d,e) /* print application (args>=1) */
372 for (h=e; isAp(h); h=fun(h)) /* find head of expression, looking*/
373 if (!isDictVal(arg(h))) /* for dictionary arguments */
376 if (args==0) { /* Special case when *all* args */
377 put(d,h); /* are dictionary values */
383 case ADDPAT : if (args==1)
384 putInfix(d,textPlus,syntaxOf(namePlus),
385 arg(e),mkInt(intValOf(fun(e))));
391 case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
392 putTuple(tupleOf(h),e);
393 CLOSE(args>tupleOf(h) && d>=FUN_PREC);
396 case NAME : if (args==1 &&
397 ((h==nameFromInt && isInt(arg(e))) ||
398 (h==nameFromDouble && isFloat(arg(e))))) {
410 case CONOPCELL : sy = defaultSyntax(t = textOf(h));
414 case EXT : if (args==2) {
419 putStr(textToStr(extText(h)));
421 put(NEVER,extField(e));
424 for (h=e; isAp(h); h=fun(h))
425 if (!isDictVal(arg(h)))
427 } while (isExt(h) && args==2);
442 default : sy = APPLIC;
448 if (sy==APPLIC) { /* print simple application */
454 else if (args==1) { /* print section of the form (e+) */
456 put(FUN_PREC-1,arg(e));
461 else if (args==2) /* infix expr of the form e1 + e2 */
462 putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
463 else { /* o/w (e1 + e2) e3 ... en (n>=3) */
465 putOverInfix(args,t,sy,e);
470 static Void local putOverInfix(args,t,sy,e)
471 Int args; /* infix applied to >= 3 arguments */
476 putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
478 put(FUN_PREC,arg(e));
481 putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
484 static Void local putInfix(d,t,sy,e,f) /* print infix expression */
486 Text t; /* Infix operator symbol */
487 Syntax sy; /* with name t, syntax s */
488 Cell e, f; { /* Left and right operands */
489 Syntax a = assocOf(sy);
493 put((a==LEFT_ASS ? p : 1+p), e);
497 put((a==RIGHT_ASS ? p : 1+p), f);
501 static Void local putSimpleAp(e,n) /* print application e0 e1 ... en */
505 putSimpleAp(maySkipDict(fun(e)),n-1);
507 put(FUN_PREC,arg(e));
513 static Void local putTuple(ts,e) /* Print tuple expression, allowing*/
514 Int ts; /* for possibility of either too */
515 Cell e; { /* few or too many args to constr */
518 if ((i=unusedTups(ts,e))>0) {
525 static Int local unusedTups(ts,e) /* print first part of tuple expr */
526 Int ts; /* returning number of constructor */
527 Cell e; { /* args not yet printed ... */
529 if ((ts=unusedTups(ts,fun(e))-1)>=0) {
531 putChr(ts>0?',':')');
535 put(FUN_PREC,arg(e));
541 Void unlexVar(t) /* print text as a variable name */
542 Text t; { /* operator symbols must be enclosed*/
543 String s = textToStr(t); /* in parentheses... except [] ... */
545 if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
546 || s[0]=='_' || s[0]=='[' || s[0]=='(')
555 static Void local unlexOp(t) /* print text as operator name */
556 Text t; { /* alpha numeric symbols must be */
557 String s = textToStr(t); /* enclosed by backquotes */
559 if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
568 Void unlexCharConst(c)
571 putStr(unlexChar(c,'\''));
575 Void unlexStrConst(t)
577 String s = textToStr(t);
578 static Char SO = 14; /* ASCII code for '\SO' */
579 Bool lastWasSO = FALSE;
580 Bool lastWasDigit = FALSE;
581 Bool lastWasEsc = FALSE;
585 String ch = unlexChar(*s,'\"');
588 if ((lastWasSO && *ch=='H') ||
589 (lastWasEsc && lastWasDigit
590 && isascii((int)(*ch)) && isdigit((int)(*ch))))
593 lastWasEsc = (*ch=='\\');
594 lastWasSO = (*s==SO);
595 for (; *ch; c = *ch++)
597 lastWasDigit = (isascii(c) && isdigit(c));
602 /* --------------------------------------------------------------------------
603 * Print type expression:
604 * ------------------------------------------------------------------------*/
606 static Void local putSigType(t) /* print (possibly) generic type */
610 Kinds ks = polySigOf(t);
611 for (; isAp(ks); ks=tl(ks))
616 putType(t,NEVER,fr); /* Finally, print rest of type ... */
619 static Void local putContext(ps,qs,fr) /* print context list */
623 Int len = length(ps) + length(qs);
628 for (; nonNull(ps); ps=tl(ps)) {
634 for (; nonNull(qs); qs=tl(qs)) {
645 static Void local putPred(pi,fr) /* Output predicate */
650 if (isExt(fun(pi))) {
651 putType(arg(pi),ALWAYS,fr);
653 putStr(textToStr(extText(fun(pi))));
659 putType(arg(pi),ALWAYS,fr);
661 else if (isClass(pi))
662 putStr(textToStr(cclass(pi).text));
664 putStr(textToStr(textOf(pi)));
666 putStr("<unknownPredicate>");
669 static Void local putType(t,prec,fr) /* print nongeneric type expression*/
674 case TYCON : putStr(textToStr(tycon(t).text));
677 case TUPLE : { Int n = tupleOf(t);
685 case POLYTYPE : { Kinds ks = polySigOf(t);
686 OPEN(prec>=ARROW_PREC);
688 for (; isAp(ks); ks=tl(ks)) {
694 putType(monotypeOf(t),NEVER,fr);
695 CLOSE(prec>=ARROW_PREC);
700 case QUAL : OPEN(prec>=ARROW_PREC);
701 if (whatIs(snd(snd(t)))==CDICTS) {
702 putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
704 putType(snd(snd(snd(snd(t)))),NEVER,fr);
706 putContext(fst(snd(t)),NIL,fr);
708 putType(snd(snd(t)),NEVER,fr);
710 CLOSE(prec>=ARROW_PREC);
714 case RANK2 : putType(snd(snd(t)),prec,fr);
717 case OFFSET : putTyVar(offsetOf(t));
721 case VAROPCELL : putChr('_');
725 case INTCELL : putChr('_');
729 case AP : { Cell typeHead = getHead(t);
730 Bool brackets = (argCount!=0 && prec>=ALWAYS);
733 if (typeHead==typeList) {
736 putType(arg(t),NEVER,fr);
741 else if (typeHead==typeArrow) {
743 OPEN(prec>=ARROW_PREC);
744 putType(arg(fun(t)),ARROW_PREC,fr);
746 putType(arg(t),NEVER,fr);
747 CLOSE(prec>=ARROW_PREC);
750 else if (argCount==1) {
752 putType(arg(t),ARROW_PREC,fr);
757 else if (isTuple(typeHead)) {
758 if (argCount==tupleOf(typeHead)) {
766 else if (isExt(typeHead)) {
772 putStr(textToStr(extText(typeHead)));
774 putType(extField(t),NEVER,fr);
776 typeHead = getHead(t);
777 } while (isExt(typeHead) && argCount==2);
792 putApType(t,args,fr);
797 default : putStr("(bad type)");
801 static Void local putTyVar(n) /* print type variable */
803 static String alphabet /* for the benefit of EBCDIC :-) */
804 ="abcdefghijklmnopqrstuvwxyz";
805 putChr(alphabet[n%26]);
806 if (n /= 26) /* just in case there are > 26 vars*/
810 static Bool local putTupleType(e,fr) /* print tuple of types, returning */
811 Cell e; /* TRUE if something was printed, */
812 Int fr; { /* FALSE otherwise; used to control*/
813 if (isAp(e)) { /* printing of intermed. commas */
814 if (putTupleType(fun(e),fr))
816 putType(arg(e),NEVER,fr);
822 static Void local putApType(t,n,fr) /* print type application */
827 putApType(fun(t),n-1,fr);
829 putType(arg(t),ALWAYS,fr);
832 putType(t,ALWAYS,fr);
835 /* --------------------------------------------------------------------------
836 * Print kind expression:
837 * ------------------------------------------------------------------------*/
839 static Void local putKind(k) /* print kind expression */
842 case AP : if (isAp(fst(k))) {
854 case ROW : putStr("row");
858 case STAR : putChr('*');
861 case OFFSET : putTyVar(offsetOf(k));
864 case INTCELL : putChr('_');
868 default : putStr("(bad kind)");
872 static Void local putKinds(ks) /* Print list of kinds */
876 else if (nonNull(tl(ks))) {
879 while (nonNull(ks=tl(ks))) {
889 /* --------------------------------------------------------------------------
891 * ------------------------------------------------------------------------*/
893 Void printExp(fp,e) /* print expr on specified stream */
901 Void printType(fp,t) /* print type on specified stream */
908 Void printContext(fp,qs) /* print context on spec. stream */
912 putContext(qs,NIL,0);
915 Void printPred(fp,pi) /* print predicate pi on stream */
922 Void printKind(fp,k) /* print kind k on stream */
929 Void printKinds(fp,ks) /* print list of kinds on stream */
936 /*-------------------------------------------------------------------------*/