/* --------------------------------------------------------------------------
 * printer.c:   Copyright (c) Mark P Jones 1991-1998.   All rights reserved.
 *              See NOTICE for details and conditions of use etc...
 *              Hugs version 1.3b, January 1998
 *
 * Builtin printer, used as an alternative to overloaded "show", and also
 * used for certain primitive types.
 * ------------------------------------------------------------------------*/

static Void   local printer		Args((Name,Int));
static Void   local outVar		Args((Text));
static Void   local outOp		Args((Text));
static Void   local outStr		Args((String));
static Void   local outPr		Args((Name,Int,Cell));
static Void   local outLPr		Args((Name,Cell));
static Void   local outBadRedex		Args((Cell));
static Cell   local printDBadRedex	Args((Cell,Cell));
static Cell   local printBadRedex	Args((Cell,Cell));
static Void   local outInst		Args((Inst));

static Name nameLPrint, nameNLPrint;	/* list printing primitives	   */
static Name nameSPrint, nameNSPrint;	/* string printing primitives	   */

static Cell out;			/* GC'd var used by printer code   */

#define outCh(c)	out = ap(consChar(c),out)
#define outSCh(c)	outStr(unlexChar(c,'\"'))
#define updOutRoot(ss)  out = revOnto(out,ss);		\
			updapRoot(fst(out),snd(out));	\
			out = NIL;

primFun(primPrint) {			/* Evaluate and print term	   */
    Cell temp;				/*    :: Int->Expr->[Char]->[Char] */
    Int  d;
    eval(primArg(3));
    d    = whnfInt;
    temp = evalWithNoError(primArg(2));
    out  = NIL;
    if (nonNull(temp)) {
	push(temp);
	outBadRedex(top());
    }
    else
	printer(namePrint,d);
    updOutRoot(primArg(1));
}

primFun(primBPrint) {			/* Eval and print value of basic   */
    Int d;				/* type -- Int, Integer, Float, or */
    eval(primArg(3));			/* Double -- as a string.	   */
    d   = whnfInt;
    eval(primArg(2));			/* Differs from primPrint only in  */
    out = NIL;				/* its use of weaker error handling*/
    printer(namePrint,d);		/* to make showsPrec strict.	   */
    updOutRoot(primArg(1));
}

primFun(primNPrint) {			/* print term without evaluation   */
    Int  d;				/*     :: Int->Expr->[Char]->[Char] */
    eval(primArg(3));
    d   = whnfInt;
    unwind(primArg(2));
    out = NIL;
    printer(nameNPrint,d);
    updOutRoot(primArg(1));
}

static Void local printer(pr,d)		/* Main part: primPrint/primNPrint */
Name pr;				/* printer to use on components	   */
Int  d; {				/* precedence level		   */
    Int used = 0;			/* Output, in reverse, to "out"	   */

    switch(whatIs(whnfHead)) {

	case NAME     : {   Syntax sy = syntaxOf(name(whnfHead).text);

			    if (!isCfun(whnfHead) ||
				    name(whnfHead).arity>whnfArgs)
				pr = nameNPrint;

			    if (whnfHead==nameCons && whnfArgs==2) {/*list */
				StackPtr ksp = sp;
				used 	     = 2;
				if (pr==namePrint) {
				    Cell temp = evalWithNoError(top());
				    if (nonNull(temp)) {
					push(temp);
					outCh('[');
					outBadRedex(top());
					sp = ksp;
					outLPr(nameLPrint,pushed(1));
				    }
				    else if (isChar(whnfHead) && whnfArgs==0) {
					outCh('"');
					outSCh(charOf(whnfHead));
					outLPr(nameSPrint,pushed(1));
				    }
				    else {
					sp = ksp;
					outCh('[');
					outPr(namePrint,MIN_PREC,top());
					outLPr(nameLPrint,pushed(1));
				    }
				}
				else {
				    unwind(top());
				    if (isChar(whnfHead) && whnfArgs==0) {
					outCh('"');
					outSCh(charOf(whnfHead));
					outLPr(nameNSPrint,pushed(1));
				    }
				    else {
					sp = ksp;
					outCh('[');
					outPr(nameNPrint,MIN_PREC,top());
					outLPr(nameNLPrint,pushed(1));
				    }
				}
				break;
			    }
			    if (whnfArgs==1 && sy!=APPLIC) {	  /* (e1+) */
				used = 1;
				outCh('(');
				outPr(pr,FUN_PREC-1,pushed(0));
				outCh(' ');
				outOp(name(whnfHead).text);
				outCh(')');
			    }
			    else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
				Syntax a = assocOf(sy);
				Int    p = precOf(sy);
				used     = 2;
				if (whnfArgs>2 || d>p)
				     outCh('(');
				outPr(pr,(a==LEFT_ASS? p:1+p),pushed(0));
				outCh(' ');
				outOp(name(whnfHead).text);
				outCh(' ');
				outPr(pr,(a==RIGHT_ASS?p:1+p),pushed(1));
				if (whnfArgs>2 || d>p)
				    outCh(')');
			    }
			    else				  /* f ... */
				outVar(name(whnfHead).text);
			}
			break;

#if BIGNUMS
	case NEGNUM   :
	case ZERONUM  :
	case POSNUM   : out = rev(bigOut(whnfHead,NIL,d>=UMINUS_PREC));
			pr  = nameNPrint;
			break;
#endif

	case INTCELL  : {   Int digit;

			    if (intOf(whnfHead)<0 && d>=UMINUS_PREC)
				outCh(')');

			    do {
				digit = whnfInt%10;
				if (digit<0)
				    digit= (-digit);
				outCh('0'+digit);
			    } while ((whnfInt/=10)!=0);

			    if (intOf(whnfHead)<0) {
				outCh('-');
				if (d>=UMINUS_PREC)
				    outCh('(');
			    }

			    out = rev(out);
			    pr  = nameNPrint;
			}
			break;

	case TUPLE    : {   Int tn   = tupleOf(whnfHead);
			    Int punc = '(';
			    Int i;

			    used     = tn<whnfArgs ? tn : whnfArgs;
			    for (i=0; i<used; ++i) {
				outCh(punc);
				outPr(pr,MIN_PREC,pushed(i));
				punc = ',';
			    }
			    for (; i<tn; ++i) {
				outCh(punc);
				punc = ',';
			    }
			    outCh(')');
			}
			pr = nameNPrint;
			break;

	case CHARCELL : outCh('\'');
			outStr(unlexChar(charOf(whnfHead), '\''));
			outCh('\'');
			pr = nameNPrint;
			break;

	case FLOATCELL: if (whnfFloat<0.0 && d>=UMINUS_PREC)
			    outCh('(');
			outStr(floatToString(whnfFloat));
			if (whnfFloat<0.0 && d>=UMINUS_PREC)
			    outCh(')');
			pr = nameNPrint;
			break;

#if HASKELL_ARRAYS
	case ARRAY    : outStr("{array}");
			pr = nameNPrint;
			break;
#endif

#if LAZY_ST
	case MUTVAR   : outStr("{mutable variable}");
			pr = nameNPrint;
			break;
#endif

#if OBJ
	case OBJREF   : outStr("{object reference}");
			pr = nameNPrint;
			break;
#endif

	case DICTCELL : outStr("{dict}");
			pr = nameNPrint;
			break;

#if IO_MONAD
	case HANDCELL : outStr("{handle}");
			pr = nameNPrint;
			break;
#endif

	case INSTANCE : outInst(whnfHead);
			pr = nameNPrint;
			break;

	default       : internal("Error in graph");
			break;
    }

    if (used<whnfArgs) {		/* Add remaining args to output	   */
	do {
	    outCh(' ');
	    outPr(pr,FUN_PREC,pushed(used));
	} while (++used<whnfArgs);

	if (d>=FUN_PREC) {		/* Determine if parens are needed  */
	    out = appendOnto(out,singleton(consChar('(')));
	    outCh(')');
	}
    }
}

/* --------------------------------------------------------------------------
 * List printing primitives:
 * ------------------------------------------------------------------------*/

primFun(primLPrint) {			/* evaluate and print list	   */
    Cell temp = evalWithNoError(primArg(2));
    out       = NIL;
    if (nonNull(temp)) {
	push(temp);
	outStr("] ++ ");
	outBadRedex(top());
    }
    else if (whnfHead==nameCons && whnfArgs==2) {
	outCh(',');
	outCh(' ');
	outPr(namePrint,MIN_PREC,pushed(0));
	outLPr(nameLPrint,pushed(1));
    }
    else if (whnfHead==nameNil && whnfArgs==0)
	outCh(']');
    else {
	outStr("] ++ ");
	outBadRedex(primArg(2));
    }
    updOutRoot(primArg(1));
}

primFun(primNLPrint) {			/* print list without evaluation   */
    unwind(primArg(2));
    out = NIL;
    if (whnfHead==nameCons && whnfArgs==2) {
	outCh(',');
	outCh(' ');
	outPr(nameNPrint,MIN_PREC,pushed(0));
	outLPr(nameNLPrint,pushed(1));
    }
    else if (whnfHead==nameNil && whnfArgs==0)
	outCh(']');
    else {
	outStr("] ++ ");
	outPr(nameNPrint,FUN_PREC-1,primArg(2));
    }
    updOutRoot(primArg(1));
}

primFun(primSPrint) {			/* evaluate and print string	   */
    Cell temp = evalWithNoError(primArg(2));
    out       = NIL;
    if (nonNull(temp)) {
	push(temp);
	outStr("\" ++ ");
	outBadRedex(top());
    }
    else if (whnfHead==nameCons && whnfArgs==2) {
	temp = evalWithNoError(top());	/* primArg(4), primArg(3) contain */
	out  = NIL;			/* the head and tail of list, resp*/
	if (nonNull(temp)) {
	    push(temp);
	    outStr("\" ++ [");
	    outBadRedex(top());
	    outLPr(nameLPrint,primArg(3));
	}
	else if (isChar(whnfHead) && whnfArgs==0) {
	    outSCh(charOf(whnfHead));
	    outLPr(nameSPrint,primArg(3));
	}
	else {
	    outStr("\" ++ [");
	    outBadRedex(primArg(4));
	    outLPr(nameLPrint,primArg(3));
	}
    }
    else if (whnfHead==nameNil && whnfArgs==0)
	outCh('"');
    else {
	outStr("\" ++ ");
	outBadRedex(primArg(2));
    }
    updOutRoot(primArg(1));
}

primFun(primNSPrint) {			/* print string without eval	   */
    unwind(primArg(2));
    out = NIL;
    if (whnfHead==nameCons && whnfArgs==2) {
	unwind(pushed(0));
	if (isChar(whnfHead) && whnfArgs==0) {
	    outSCh(charOf(whnfHead));
	    outLPr(nameNSPrint,primArg(3));
	}
	else {
	    outStr("\" ++ [");
	    outPr(nameNPrint,MIN_PREC,primArg(4));
	    outLPr(nameNLPrint,primArg(3));
	}
    }
    else if (whnfHead==nameNil && whnfArgs==0)
	outCh('"');
    else {
	outStr("\" ++ ");
	outPr(nameNPrint,FUN_PREC-1,primArg(2));
    }
    updOutRoot(primArg(1));
}

/* --------------------------------------------------------------------------
 * Auxiliary functions for printer(s):
 * ------------------------------------------------------------------------*/

static Void local outVar(t)		/* output t as function symbol	   */
Text t; {
    String s = textToStr(t);
    if ((isascii(*s) && isalpha(*s)) || *s=='_' || *s=='[' || *s=='(')
	outStr(s);
    else {
	outCh('(');
	outStr(s);
	outCh(')');
    }
}

static Void local outOp(t)		/* output t as operator symbol	   */
Text t; {
    String s = textToStr(t);
    if (isascii(s[0]) && isalpha(s[0])) {
	outCh('`');
	outStr(s);
	outCh('`');
    }
    else
	outStr(s);
}

static Void local outStr(s)		/* output string s		   */
String s; {
    while (*s)
	outCh(*s++);
}

static Void local outPr(pr,d,e)		/* output expr e with printer pr,  */
Name pr;				/* precedence d			   */
Int  d;
Cell e; {
    out           = ap(NIL,out);
    fst(out)      = ap(NIL,e);
    fst(fst(out)) = ap(pr,mkInt(d));
}

static Void local outLPr(pr,xs)		/* output list xs with printer pr  */
Name pr;
Cell xs; {
    out      = ap(NIL,out);
    fst(out) = ap(pr,xs);
}

static Void local outBadRedex(rx)	/* Produce expr to print bad redex */
Cell rx; {
    outCh('{');
    outPr(nameNPrint,MIN_PREC,rx);
    outCh('}');
}

static Cell local printDBadRedex(rx,rs)	/* Produce expression for bad	   */
Cell rx, rs; {				/* redex with special handling	   */
    if (isAp(rx) && fun(rx)==nameError) /* of {error str} redexes	   */
	return arg(rx);
    else
	return printBadRedex(rx,rs);
}

static Cell local printBadRedex(rx,rs)	/* produce expression for bad	   */
Cell rx, rs; {				/* redex			   */
   out = NIL;
   outBadRedex(rx);
   return revOnto(out,rs);
}

Void abandon(what,rx)			/* abandon computation		   */
String what;
Cell   rx; {
    push(printDBadRedex(rx,nameNil));
    out   = NIL;
    outCh('\n');
    outStr(what);
    outStr(" error: ");
    top() = revOnto(out,top());
    out   = NIL;
    outputString(errorStream);
    errAbort();
}

static Void local outInst(in)		/* produce string representation   */
Inst in; {				/* of instance			   */
    outStr(textToStr(cclass(inst(in).c).text));
    outCh('-');
    switch (whatIs(inst(in).t)) {
	case TUPLE : {   Int n = tupleOf(inst(in).t);
			 outCh('(');
			 for (; n>0; --n)
			     outCh(',');
			 outCh(')');
		     }
		     return;

	case TYCON : outStr(textToStr(tycon(inst(in).t).text));
		     return;

	default	   : outStr("???");
		     return;
    }
}

/*-------------------------------------------------------------------------*/