/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--1998  Robert Gentleman, Ross Ihaka and the R Core team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "Defn.h"
#include "Print.h"
#include "names.h"
#include "Fileio.h"

/*
 *	Global Variables:
 *
 *	linenumber: counts the number of lines that have been written,
 *	this is used to setup storage for deparsing.
 *
 *	len: counts the length of the current line, it will be used to
 *	determine when to break lines.
 *
 *	incurly: keeps track of whether we are inside a curly or not,
 *	this affects the printing of if-then-else.
 *
 *	inlist: keeps track of whether we are inside a list or not,
 *	this affects the printing of if-then-else.
 *
 *	startline: indicator 0=start of a line (so we can tab out to
 *	the correct place).
 *
 *	indent: how many tabs should be written at the start of a line.
 *
 *	buff: contains the current string, we attempt to break lines at
 *	cutoff, but can handle up to BUFSIZE characters.
 *
 *	lbreak: often used to indicate whether a line has been broken,
 *	this makes sure that that indenting behaves itself.
 */
#define BUFSIZE 512

#define MIN_Cutoff 20
#define DEFAULT_Cutoff 60
#define MAX_Cutoff (BUFSIZE - 12)
/* ----- MAX_Cutoff  <	BUFSIZE !! */

static int cutoff = DEFAULT_Cutoff;

static char buff[BUFSIZE];
static int linenumber;
static int len;
static int incurly = 0;
static int inlist = 0;
static int startline = 0;
static int indent = 0;
static SEXP strvec;

static void args2buff(SEXP, int, int);
static void deparse2buff(SEXP);
static void print2buff(char *);
static void printtab2buff(int);
static void scalar2buff(SEXP);
static void writeline(void);
#ifdef NotUsed
static void factor2buff(SEXP, int);
#endif
static void vector2buff(SEXP);
static void vec2buff(SEXP);
static void linebreak();
void deparse2(SEXP, SEXP);


	/* Deparsing, has 3 layers.  The user interface, do_deparse, */
	/* should not be called from an internal function, the actual */
	/* deparsing needs to be done twice, once to count things up */
	/* and a second time to put them into the string vector for return. */
	/* Printing this to a file is handled by the calling routine. */

/* DEBUG_ME
	The code below saves and restores the value of the global
	variable "cutoff".  This could create a problem if a user
	interrupts the deparse before there is a chance to restore
	the value.  One possible fix is to restructure the code
	with another function which takes a cutoff value as a
	parameter.  Then "do_deparse" and "deparse1" could each
	call this deeper function with the appropriate argument.

	I wonder why I didn't just do this? -- it would have been
	quicker than writing this note.	 I guess it needs a bit
	more thought ...
*/


SEXP do_deparse(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP ca1;
	int savecutoff, cut0;
	/*checkArity(op, args);*/
	if(length(args) < 1) errorcall(call, "too few arguments\n");

	ca1 = CAR(args); args = CDR(args);
	savecutoff = cutoff;
	cutoff = DEFAULT_Cutoff;
	if(!isNull(CAR(args))) {
		cut0 = asInteger(CAR(args));
		if(cut0 == NA_INTEGER|| cut0 < MIN_Cutoff || cut0 > MAX_Cutoff)
			warning("invalid 'cutoff' for deparse, used default\n");
		else
			cutoff = cut0;
	}
	ca1 = deparse1(ca1, 0);
	cutoff = savecutoff;
	return ca1;
}

	/* The function deparse1 gets a second argument; abbrev. */
	/* If abbrev is 1 then the returned value is a STRSXP of */
	/* length 1 with at most 10 characters.	 This is use for */
	/* plot labelling etc. */

SEXP deparse1(SEXP call, int abbrev)
{
	SEXP svec;
	int savedigits;

	svec = R_NilValue;
	savedigits = print_digits;
	deparse2(call, svec);
	PROTECT(svec = allocVector(STRSXP, linenumber));
	deparse2(call, svec);
	UNPROTECT(1);
	if (abbrev == 1) {
		buff[0]='\0';
		strncat(buff, CHAR(STRING(svec)[0]), 10);
		if (strlen(CHAR(STRING(svec)[0])) > 10)
			strcat(buff, "...");
		svec = mkString(buff);
	}
	print_digits = savedigits;
	return svec;
}

SEXP do_dput(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	FILE *fp;
	SEXP tval;
	SEXP saveenv;
	int i;

	checkArity(op, args);
	tval = CAR(args);
	if (TYPEOF(tval) == CLOSXP) {
		PROTECT(saveenv = CLOENV(tval));
		CLOENV(tval) = R_GlobalEnv;
	}
	tval = deparse1(tval, 0);
	if (TYPEOF(CAR(args)) == CLOSXP) {
		CLOENV(CAR(args)) = saveenv;
		UNPROTECT(1);
	}
	fp = NULL;
	if (strlen(CHAR(STRING(CADR(args))[0])) > 0) {
		fp = R_fopen(CHAR(STRING(CADR(args))[0]), "w");
		if (!fp)
			errorcall(call, "unable to open file\n");
	}
	for (i = 0; i < LENGTH(tval); i++)
		if (fp == NULL)
			Rprintf("%s\n", CHAR(STRING(tval)[i]));
		else
			fprintf(fp, "%s\n", CHAR(STRING(tval)[i]));
	if (fp != NULL)
		fclose(fp);
	return (CAR(args));
}

SEXP do_dump(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP names, file, o, objs, tval;
	int i, j, nobjs;
	FILE *fp;

	checkArity(op, args);

	names = CAR(args);
	file = CADR(args);
	if(!isString(names) || !isString(file))
		errorcall(call, "character arguments expected\n");
	nobjs = length(names);
	if(nobjs < 1 || length(file) < 1)
		errorcall(call, "zero length argument\n");

	PROTECT(o = objs = allocList(nobjs));

	for(i=0 ; i<nobjs ; i++) {
		CAR(o) = eval(install(CHAR(STRING(names)[i])), rho);
		o = CDR(o);
	}

	o = objs;
	if(strlen(CHAR(STRING(CADR(args))[0])) == 0) {
		for (i = 0; i < nobjs; i++) {
			Rprintf("\"%s\" <-\n", CHAR(STRING(names)[i]));
			tval = deparse1(CAR(o), 0);
			for (j = 0; j<LENGTH(tval); j++) {
				Rprintf("%s\n", CHAR(STRING(tval)[j]));
			}
			o = CDR(o);
		}
	}
	else {
		if(!(fp = R_fopen(CHAR(STRING(CADR(args))[0]), "w")))
			errorcall(call, "unable to open file\n");
		for (i = 0; i < nobjs; i++) {
			fprintf(fp, "\"%s\" <-\n", CHAR(STRING(names)[i]));
			tval = deparse1(CAR(o), 0);
			for (j = 0; j<LENGTH(tval); j++) {
				fprintf(fp, "%s\n", CHAR(STRING(tval)[j]));
			}
			o = CDR(o);
		}
		fclose(fp);
	}

	UNPROTECT(1);
	R_Visible = 0;
	return names;
}

static void linebreak(int *lbreak)
{
	if (len > cutoff) {
		if (!*lbreak) {
			*lbreak = 1;
			indent++;
		}
		writeline();
	}
}

void deparse2(SEXP what, SEXP svec)
{
	PrintDefaults(R_NilValue);
	strvec = svec;
	linenumber = 0;
	indent = 0;
	deparse2buff(what);
	writeline();
}


	/* curlyahead looks at s to see if it is a list with */
	/* the first op being a curly. You need this kind of */
	/* lookahead info to print if statements correctly.  */

static int curlyahead(SEXP s)
{
	if (isList(s) || isLanguage(s))
		if (TYPEOF(CAR(s)) == SYMSXP && CAR(s) == install("{"))
			return 1;
	return 0;
}

static void attr1(SEXP s)
{
	if(ATTRIB(s) != R_NilValue)
		print2buff("structure(");
}

static void attr2(SEXP s)
{
	if(ATTRIB(s) != R_NilValue) {
		SEXP a = ATTRIB(s);
		while(!isNull(a)) {
			print2buff(", ");
			if(TAG(a) == R_DimSymbol) {
				print2buff(".Dim");
			}
			else if(TAG(a) == R_DimNamesSymbol) {
				print2buff(".Dimnames");
			}
			else if(TAG(a) == R_NamesSymbol) {
				print2buff(".Names");
			}
			else if(TAG(a) == R_TspSymbol) {
				print2buff(".Tsp");
			}
			else if(TAG(a) == R_LevelsSymbol) {
				print2buff(".Label");
			}
			else deparse2buff(TAG(a));
			print2buff(" = ");
			deparse2buff(CAR(a));
			a = CDR(a);
		}
		print2buff(")");
	}
}


static void printcomment(SEXP s)
{
	SEXP cmt;
	int i, ncmt;

	/* look for old-style comments first */

	if(isList(TAG(s)) && !isNull(TAG(s))) {
		for (s=TAG(s); s != R_NilValue; s = CDR(s)) {
			print2buff(CHAR(STRING(CAR(s))[0]));
			writeline();
		}
	}
	else {
		cmt = getAttrib(s, R_CommentSymbol);
		ncmt = length(cmt);
		for(i=0 ; i<ncmt ; i++) {
			print2buff(CHAR(STRING(cmt)[i]));
			writeline();
		}
	}
}

	/* This is the recursive part of deparsing. */

static void deparse2buff(SEXP s)
{
	int fop, lookahead, lbreak = 0;
	SEXP op, t;
	char tpb[120];

	switch (TYPEOF(s)) {
	case NILSXP:
		print2buff("NULL");
		break;
	case SYMSXP:
		print2buff(CHAR(PRINTNAME(s)));
		break;
	case CHARSXP:
		print2buff(CHAR(s));
		break;
	case SPECIALSXP:
	case BUILTINSXP:
		sprintf(tpb, ".Primitive(\"%s\")", PRIMNAME(s));
		print2buff(tpb);
		break;
	case PROMSXP:
		deparse2buff(PREXPR(s));
		break;
	case CLOSXP:
		print2buff("function (");
		args2buff(FORMALS(s), 0, 1);
		print2buff(") ");
		writeline();
		deparse2buff(BODY(s));
		break;
	case ENVSXP:
		print2buff("<environment>");
		break;
	case EXPRSXP:
		if(length(s) <= 0) print2buff("expression()");
		else {
			print2buff("expression(");
			vec2buff(s);
			print2buff(")");
		}
		break;
	case LISTSXP:
		attr1(s);
		print2buff("list(");
		inlist++;
		for (t=s ; CDR(t) != R_NilValue ; t=CDR(t) ) {
			if( TAG(t) != R_NilValue ) {
				deparse2buff(TAG(t));
				print2buff(" = ");
			}
			deparse2buff(CAR(t));
			print2buff(", ");
		}
		if( TAG(t) != R_NilValue ) {
			deparse2buff(TAG(t));
			print2buff(" = ");
		}
		deparse2buff(CAR(t));
		print2buff(")" );
		inlist--;
		attr2(s);
		break;
	case LANGSXP:
		printcomment(s);
		if (TYPEOF(CAR(s)) == SYMSXP) {
			if ((TYPEOF(SYMVALUE(CAR(s))) == BUILTINSXP) ||
					(TYPEOF(SYMVALUE(CAR(s))) == SPECIALSXP)) {
				op = CAR(s);
				fop = PPINFO(SYMVALUE(op));
				s = CDR(s);
				if (fop == PP_BINARY && length(s) == 1)
					fop = PP_UNARY;
				switch (fop) {
				case PP_IF:
					print2buff("if (");
					/* print the predicate */
					deparse2buff(CAR(s));
					print2buff(") ");
					if (incurly && !inlist ) {
						lookahead = curlyahead(CAR(CDR(s)));
						if (!lookahead) {
							writeline();
							indent++;
						}
					}
					/* need to find out if there is an else */
					if (length(s) > 2) {
						deparse2buff(CAR(CDR(s)));
						if (incurly && !inlist) {
							writeline();
							if (!lookahead)
								indent--;
						}
						else
							print2buff(" ");
						print2buff("else ");
						deparse2buff(CAR(CDDR(s)));
					}
					else {
						deparse2buff(CAR(CDR(s)));
						if (incurly && !lookahead && !inlist )
							indent--;
					}
					break;
				case PP_WHILE:
					print2buff("while (");
					deparse2buff(CAR(s));
					print2buff(") ");
					deparse2buff(CADR(s));
					break;
				case PP_FOR:
					print2buff("for (");
					deparse2buff(CAR(s));
					print2buff(" in ");
					deparse2buff(CADR(s));
					print2buff(") ");
					deparse2buff(CADR(CDR(s)));
					break;
				case PP_REPEAT:
					print2buff("repeat ");
					deparse2buff(CAR(s));
					break;
				case PP_CURLY:
					print2buff("{");
					incurly += 1;
					indent++;
					writeline();
					while (s != R_NilValue) {
						deparse2buff(CAR(s));
						writeline();
						s = CDR(s);
					}
					indent--;
					print2buff("}");
					incurly -= 1;
					break;
				case PP_PAREN:
					print2buff("(");
					deparse2buff(CAR(s));
					print2buff(")");
					break;
				case PP_SUBSET:
					deparse2buff(CAR(s));
					if (PRIMVAL(SYMVALUE(op)) == 1)
						print2buff("[");
					else
						print2buff("[[");
					args2buff(CDR(s), 0, 0);
					if (PRIMVAL(SYMVALUE(op)) == 1)
						print2buff("]");
					else
						print2buff("]]");
					break;
				case PP_FUNCALL:
				case PP_RETURN:
					print2buff(CHAR(PRINTNAME(op)));
					print2buff("(");
					inlist++;
					args2buff(s, 0, 0);
					inlist--;
					print2buff(")");
					break;
				case PP_FOREIGN:
					print2buff(CHAR(PRINTNAME(op)));
					print2buff("(");
					inlist++;
					args2buff(s, 1, 0);
					inlist--;
					print2buff(")");
					break;
				case PP_FUNCTION:
					printcomment(s);
					print2buff(CHAR(PRINTNAME(op)));
					print2buff("(");
					args2buff(FORMALS(s), 0, 1);
					print2buff(") ");
					deparse2buff(CADR(s));
					break;
				case PP_ASSIGN:
				case PP_ASSIGN2:
					deparse2buff(CAR(s));
					print2buff(" ");
					print2buff(CHAR(PRINTNAME(op)));
					print2buff(" ");
					deparse2buff(CADR(s));
					break;
				case PP_DOLLAR:
					deparse2buff(CAR(s));
					print2buff("$");
					deparse2buff(CADR(s));
					break;
				case PP_BINARY:
					deparse2buff(CAR(s));
					print2buff(" ");
					print2buff(CHAR(PRINTNAME(op)));
					print2buff(" ");
					linebreak(&lbreak);
					deparse2buff(CADR(s));
					if (lbreak) {
						indent--;
						lbreak = 0;
					}
					break;
				case PP_BINARY2:	/* no space between op and args */
					deparse2buff(CAR(s));
					print2buff(CHAR(PRINTNAME(op)));
					deparse2buff(CADR(s));
					break;
				case PP_UNARY:
					print2buff(CHAR(PRINTNAME(op)));
					deparse2buff(CAR(s));
					break;
				case PP_BREAK:
					print2buff("break");
					break;
				case PP_NEXT:
					print2buff("next");
					break;
				case PP_SUBASS:
					print2buff("\"");
					print2buff(CHAR(PRINTNAME(op)));
					print2buff("\"(");
					args2buff(s, 0, 0);
					print2buff(")");
					break;
				default:
					UNIMPLEMENTED("deparse2buff");
				}
			}
			else {
				if(isSymbol(CAR(s)) && isUserBinop(CAR(s))) {
					op = CAR(s);
					s = CDR(s);
					deparse2buff(CAR(s));
					print2buff(" ");
					print2buff(CHAR(PRINTNAME(op)));
					print2buff(" ");
					linebreak(&lbreak);
					deparse2buff(CADR(s));
					if (lbreak) {
						indent--;
						lbreak = 0;
					}
					break;
				}
				else {
					deparse2buff(CAR(s));
					print2buff("(");
					args2buff(CDR(s), 0, 0);
					print2buff(")");
				}
			}
		}
		else if (TYPEOF(CAR(s)) == CLOSXP || TYPEOF(CAR(s)) == SPECIALSXP
			 || TYPEOF(CAR(s)) == BUILTINSXP) {
			deparse2buff(CAR(s));
			print2buff("(");
			args2buff(CDR(s), 0, 0);
			print2buff(")");
		}
		else {
			deparse2buff(CAR(s));
			if( CDR(s) != R_NilValue ) {
				/* we have a lambda expression and need
					to print the args */
				print2buff("(");
				args2buff(CDR(s), 0, 0);
				print2buff(")");
			}
		}
		break;
	case STRSXP:
	case LGLSXP:
	case INTSXP:
	case REALSXP:
	case CPLXSXP:
		attr1(s);
		vector2buff(s);
		attr2(s);
		break;
	default:
		UNIMPLEMENTED("deparse2buff");
	}
}

/*
   if there is a string array active point to that, and
   otherwise we are counting lines so don't do anything
 */

static void writeline()
{
	if (strvec != R_NilValue)
		STRING(strvec)[linenumber] = mkChar(buff);
	linenumber++;
	/* reset */
	len = 0;
	buff[0] = '\0';
	startline = 0;
}

static void print2buff(char *strng)
{
	int tlen, bufflen;

	if (startline == 0) {
		startline = 1;
		printtab2buff(indent);	/*if at the start of a line tab over */
	}
	tlen = strlen(strng);
	bufflen = strlen(buff);
	if (bufflen + tlen > BUFSIZE) {
		buff[0] = '\0';
		error("string too long in deparse\n");
	}
	strcat(buff, strng);
	len += tlen;
}

static void scalar2buff(SEXP inscalar)
{
	char *strp;
	strp = EncodeElement(inscalar, 0, '"');
	print2buff(strp);
}

static void vector2buff(SEXP vector)
{
	int tlen, i, quote;
	char *strp;

	tlen = length(vector);
	if( isString(vector) )
		quote='"';
	else
		quote=0;
	if (tlen == 0) {
		switch(TYPEOF(vector)) {
		case LGLSXP: print2buff("logical(0)"); break;
		case INTSXP: print2buff("numeric(0)"); break;
		case REALSXP: print2buff("numeric(0)"); break;
		case CPLXSXP: print2buff("complex(0)"); break;
		case STRSXP: print2buff("character(0)"); break;
		}
	}
	else if (tlen == 1) {
		scalar2buff(vector);
	}
	else {
		print2buff("c(");
		for (i = 0; i < tlen; i++) {
			strp = EncodeElement(vector, i, quote);
			print2buff(strp);
			if (i < (tlen - 1))
				print2buff(", ");
			if (len > cutoff)
				writeline();
		}
		print2buff(")");
	}

}

#ifdef NotUsed
static void factor2buff(SEXP vector, int ordered)
{
	int tlen, i;
	char *strp;

	tlen = length(vector);
	if(ordered) print2buff("ordered(c(");
	else print2buff("factor(c(");
	for (i = 0; i < tlen; i++) {
		strp = EncodeInteger(INTEGER(vector)[i], 0);
		print2buff(strp);
		if (i < (tlen - 1))
			print2buff(", ");
		if (len > cutoff)
			writeline();
	}
	print2buff("), levels=1:");
	strp = EncodeInteger(LEVELS(vector), 0);
	print2buff(strp);
	print2buff(")");
}
#endif
/* vec2buff : New Code */
/* Deparse vectors of S-expressions. */
/* In particular, this deparses objects of mode expression. */

static void vec2buff(SEXP v)
{
	SEXP nv;
	int i, lbreak, n;

	lbreak = 0;
	n = length(v);
	nv = getAttrib(v, R_NamesSymbol);
	if (length(nv) == 0) nv = R_NilValue;

	for(i=0 ; i<n ; i++) {
		if (i > 0)
			print2buff(", ");
		linebreak(&lbreak);
		if (!isNull(nv) && !isNull(STRING(nv)[i])
		    && *CHAR(STRING(nv)[i])) {
			deparse2buff(STRING(nv)[i]);
			print2buff(" = ");
		}
		deparse2buff(VECTOR(v)[i]);
	}
	if (lbreak)
		indent--;
}

static void args2buff(SEXP arglist, int lineb, int formals)
{
	int lbreak = 0;

	while (arglist != R_NilValue) {
		if (TAG(arglist) != R_NilValue) {
			deparse2buff(TAG(arglist));
			if(formals) {
				if (CAR(arglist) != R_MissingArg) {
					print2buff(" = ");
					deparse2buff(CAR(arglist));
				}
			}
			else {
				print2buff(" = ");
				if (CAR(arglist) != R_MissingArg) {
					deparse2buff(CAR(arglist));
				}
			}
		}
		else deparse2buff(CAR(arglist));
		arglist = CDR(arglist);
		if (arglist != R_NilValue) {
			print2buff(", ");
			linebreak(&lbreak);
		}
	}
	if (lbreak)
		indent--;
}

/*
   following the S style, print 4 tabs and then start printing spaces only
 */

static void printtab2buff(int ntab)
{
	int i;

	for (i = 1; i <= ntab; i++)
		if (i <= 4)
			print2buff("	    ");
		else
			print2buff(" ");
}
