/* --------------------------------------------------------------------------
 * Operations on Chars.
 *
 * Extended to Unicode by Dimitry Golubovsky <dimitry@golubovsky.org>.
 *
 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
 * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU,
 * 1994-2005, All rights reserved.  It is distributed as free software under
 * the license in the file "License", which is included in the distribution.
 * ------------------------------------------------------------------------*/

#include "prelude.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
#include "char.h"
#include <errno.h>

/* --------------------------------------------------------------------------
 * Unicode character properties (cf http://www.unicode.org/ucd/)
 * ------------------------------------------------------------------------*/

/* Unicode general categories, listed in the same order as in the Unicode
 * standard -- this must be the same order as in Data.Char.
 */
enum {
    GENCAT_Lu,	/* Letter, Uppercase */
    GENCAT_Ll,	/* Letter, Lowercase */
    GENCAT_Lt,	/* Letter, Titlecase */
    GENCAT_Lm,	/* Letter, Modifier */
    GENCAT_Lo,	/* Letter, Other */
    GENCAT_Mn,	/* Mark, Non-Spacing */
    GENCAT_Mc,	/* Mark, Spacing Combining */
    GENCAT_Me,	/* Mark, Enclosing */
    GENCAT_Nd,	/* Number, Decimal */
    GENCAT_Nl,	/* Number, Letter */
    GENCAT_No,	/* Number, Other */
    GENCAT_Pc,	/* Punctuation, Connector */
    GENCAT_Pd,	/* Punctuation, Dash */
    GENCAT_Ps,	/* Punctuation, Open */
    GENCAT_Pe,	/* Punctuation, Close */
    GENCAT_Pi,	/* Punctuation, Initial quote */
    GENCAT_Pf,	/* Punctuation, Final quote */
    GENCAT_Po,	/* Punctuation, Other */
    GENCAT_Sm,	/* Symbol, Math */
    GENCAT_Sc,	/* Symbol, Currency */
    GENCAT_Sk,	/* Symbol, Modifier */
    GENCAT_So,	/* Symbol, Other */
    GENCAT_Zs,	/* Separator, Space */
    GENCAT_Zl,	/* Separator, Line */
    GENCAT_Zp,	/* Separator, Paragraph */
    GENCAT_Cc,	/* Other, Control */
    GENCAT_Cf,	/* Other, Format */
    GENCAT_Cs,	/* Other, Surrogate */
    GENCAT_Co,	/* Other, Private Use */
    GENCAT_Cn	/* Other, Not Assigned */
};

/* --------------------------------------------------------------------------
 * Local function prototypes:
 * ------------------------------------------------------------------------*/

static Void local initConsCharTable	Args((Void));
static Void local markConsCharTable	Args((Void));

/* --------------------------------------------------------------------------
 * Character set handling:
 *
 * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
 * (Latin-1) character set.  The following code provides methods for
 * classifying input characters according to the lexical structure
 * specified by the report.  Hugs should still accept older programs
 * because ASCII is just a subset of the Latin-1 character set.
 * ------------------------------------------------------------------------*/

Bool		charTabBuilt;
unsigned char   charTable[NUM_LAT1_CHARS];

Void initCharTab() {			/* Initialize char decode table    */
#define setRange(x,f,t) {Int i=f;   while (i<=t) charTable[i++] |=x;}
#define setChar(x,c)	charTable[c] |= (x)
#define setChars(x,s)   {char *p=s; while (*p)   charTable[(Int)*p++]|=x;}
#define setCopy(x,c)    {Int i;                         \
			 for (i=0; i<NUM_LAT1_CHARS; ++i)    \
			     if (isIn(i,c))             \
				 charTable[i]|=x;          \
			}

    setRange(DIGIT,     '0','9');	/* ASCII decimal digits		   */

    setRange(SMALL,     'a','z');	/* ASCII lower case letters	   */
    setChar (SMALL,     170);		/* Feminine ordinal indicator      */
    setChar (SMALL,     181);		/* Micro sign                      */
    setChar (SMALL,     186);		/* Masculine ordinal indicator     */
    setRange(SMALL,     223,246);	/* Latin-1 lower case letters	   */
    setRange(SMALL,     248,255);	/* (omits division symbol, 247)	   */
    setChar (SMALL,     '_');

    setRange(LARGE,     'A','Z');	/* ASCII upper case letters	   */
    setRange(LARGE,     192,214);	/* Latin-1 upper case letters	   */
    setRange(LARGE,     216,222);	/* (omits multiplication, 215)	   */

    setRange(SYMBOL,    161,191);	/* Symbol characters + ':'	   */
    setRange(SYMBOL,    215,215);
    setChar (SYMBOL,    247);
    setChars(SYMBOL,    ":!#$%&*+./<=>?@\\^|-~");

    setChar (IDAFTER,   '\'');		/* Characters in identifier	   */
    setCopy (IDAFTER,   (DIGIT|SMALL|LARGE));

    setChar (SPACE,     ' ');		/* ASCII space character	   */
    setChar (SPACE,     160);		/* Latin-1 non breaking space	   */
    setRange(SPACE,     9,13);		/* special whitespace: \t\n\v\f\r  */

    setRange(PRINT,     32,126);
    setRange(PRINT,     160,172);
    setRange(PRINT,     174,255);	/* (omits soft hyphen)             */
    
#undef setRange
#undef setChar
#undef setChars
#undef setCopy

    charTabBuilt = TRUE;
}

/* --------------------------------------------------------------------------
 * Char primitives.
 * ------------------------------------------------------------------------*/

/* Latin-1 only */

Char toUpper(Char c) {
    /* two lowercase letters have no Latin-1 uppercase counterpart */
    if (isLower(c) && c!=0xdf && c!=0xff)
	return c - 'a' + 'A';
    return c;
}

Char toLower(Char c) {
    if (isUpper(c))
	return c - 'A' + 'a';
    return c;
}

Char toTitle(Char c) {
    return toUpper(c);
}

/* Unicode general categories for the Latin-1 subset */
static const char char_category[] = {
	/* '\NUL' */	/* '\SOH' */	/* '\STX' */	/* '\ETX' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\EOT' */	/* '\ENQ' */	/* '\ACK' */	/* '\a' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\b' */	/* '\t' */	/* '\n' */	/* '\v' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\f' */	/* '\r' */	/* '\SO' */	/* '\SI' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\DLE' */	/* '\DC1' */	/* '\DC2' */	/* '\DC3' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\DC4' */	/* '\NAK' */	/* '\SYN' */	/* '\ETB' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\CAN' */	/* '\EM' */	/* '\SUB' */	/* '\ESC' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\FS' */	/* '\GS' */	/* '\RS' */	/* '\US' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* ' ' */	/* '!' */	/* '"' */	/* '#' */
	GENCAT_Zs,	GENCAT_Po,	GENCAT_Po,	GENCAT_Po,
	/* '$' */	/* '%' */	/* '&' */	/* '\'' */
	GENCAT_Sc,	GENCAT_Po,	GENCAT_Po,	GENCAT_Po,
	/* '(' */	/* ')' */	/* '*' */	/* '+' */
	GENCAT_Ps,	GENCAT_Pe,	GENCAT_Po,	GENCAT_Sm,
	/* ',' */	/* '-' */	/* '.' */	/* '/' */
	GENCAT_Po,	GENCAT_Pd,	GENCAT_Po,	GENCAT_Po,
	/* '0' */	/* '1' */	/* '2' */	/* '3' */
	GENCAT_Nd,	GENCAT_Nd,	GENCAT_Nd,	GENCAT_Nd,
	/* '4' */	/* '5' */	/* '6' */	/* '7' */
	GENCAT_Nd,	GENCAT_Nd,	GENCAT_Nd,	GENCAT_Nd,
	/* '8' */	/* '9' */	/* ':' */	/* ';' */
	GENCAT_Nd,	GENCAT_Nd,	GENCAT_Po,	GENCAT_Po,
	/* '<' */	/* '=' */	/* '>' */	/* '?' */
	GENCAT_Sm,	GENCAT_Sm,	GENCAT_Sm,	GENCAT_Po,
	/* '@' */	/* 'A' */	/* 'B' */	/* 'C' */
	GENCAT_Po,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'D' */	/* 'E' */	/* 'F' */	/* 'G' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'H' */	/* 'I' */	/* 'J' */	/* 'K' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'L' */	/* 'M' */	/* 'N' */	/* 'O' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'P' */	/* 'Q' */	/* 'R' */	/* 'S' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'T' */	/* 'U' */	/* 'V' */	/* 'W' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* 'X' */	/* 'Y' */	/* 'Z' */	/* '[' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Ps,
	/* '\\' */	/* ']' */	/* '^' */	/* '_' */
	GENCAT_Po,	GENCAT_Pe,	GENCAT_Sk,	GENCAT_Pc,
	/* '`' */	/* 'a' */	/* 'b' */	/* 'c' */
	GENCAT_Sk,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 'd' */	/* 'e' */	/* 'f' */	/* 'g' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 'h' */	/* 'i' */	/* 'j' */	/* 'k' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 'l' */	/* 'm' */	/* 'n' */	/* 'o' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 'p' */	/* 'q' */	/* 'r' */	/* 's' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 't' */	/* 'u' */	/* 'v' */	/* 'w' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* 'x' */	/* 'y' */	/* 'z' */	/* '{' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ps,
	/* '|' */	/* '}' */	/* '~' */	/* '\DEL' */
	GENCAT_Sm,	GENCAT_Pe,	GENCAT_Sm,	GENCAT_Cc,
	/* '\128' */	/* '\129' */	/* '\130' */	/* '\131' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\132' */	/* '\133' */	/* '\134' */	/* '\135' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\136' */	/* '\137' */	/* '\138' */	/* '\139' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\140' */	/* '\141' */	/* '\142' */	/* '\143' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\144' */	/* '\145' */	/* '\146' */	/* '\147' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\148' */	/* '\149' */	/* '\150' */	/* '\151' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\152' */	/* '\153' */	/* '\154' */	/* '\155' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\156' */	/* '\157' */	/* '\158' */	/* '\159' */
	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,	GENCAT_Cc,
	/* '\160' */	/* '\161' */	/* '\162' */	/* '\163' */
	GENCAT_Zs,	GENCAT_Po,	GENCAT_Sc,	GENCAT_Sc,
	/* '\164' */	/* '\165' */	/* '\166' */	/* '\167' */
	GENCAT_Sc,	GENCAT_Sc,	GENCAT_So,	GENCAT_So,
	/* '\168' */	/* '\169' */	/* '\170' */	/* '\171' */
	GENCAT_Sk,	GENCAT_So,	GENCAT_Ll,	GENCAT_Pi,
	/* '\172' */	/* '\173' */	/* '\174' */	/* '\175' */
	GENCAT_Sm,	GENCAT_Cf,	GENCAT_So,	GENCAT_Sk,
	/* '\176' */	/* '\177' */	/* '\178' */	/* '\179' */
	GENCAT_So,	GENCAT_Sm,	GENCAT_No,	GENCAT_No,
	/* '\180' */	/* '\181' */	/* '\182' */	/* '\183' */
	GENCAT_Sk,	GENCAT_Ll,	GENCAT_So,	GENCAT_Po,
	/* '\184' */	/* '\185' */	/* '\186' */	/* '\187' */
	GENCAT_Sk,	GENCAT_No,	GENCAT_Ll,	GENCAT_Pf,
	/* '\188' */	/* '\189' */	/* '\190' */	/* '\191' */
	GENCAT_No,	GENCAT_No,	GENCAT_No,	GENCAT_Po,
	/* '\192' */	/* '\193' */	/* '\194' */	/* '\195' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\196' */	/* '\197' */	/* '\198' */	/* '\199' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\200' */	/* '\201' */	/* '\202' */	/* '\203' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\204' */	/* '\205' */	/* '\206' */	/* '\207' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\208' */	/* '\209' */	/* '\210' */	/* '\211' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\212' */	/* '\213' */	/* '\214' */	/* '\215' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Sm,
	/* '\216' */	/* '\217' */	/* '\218' */	/* '\219' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,
	/* '\220' */	/* '\221' */	/* '\222' */	/* '\223' */
	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Lu,	GENCAT_Ll,
	/* '\224' */	/* '\225' */	/* '\226' */	/* '\227' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\228' */	/* '\229' */	/* '\230' */	/* '\231' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\232' */	/* '\233' */	/* '\234' */	/* '\235' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\236' */	/* '\237' */	/* '\238' */	/* '\239' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\240' */	/* '\241' */	/* '\242' */	/* '\243' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\244' */	/* '\245' */	/* '\246' */	/* '\247' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Sm,
	/* '\248' */	/* '\249' */	/* '\250' */	/* '\251' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,
	/* '\252' */	/* '\253' */	/* '\254' */	/* '\255' */
	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll,	GENCAT_Ll
};

Int uni_gencat(Char c) {
    return char_category[c];
}


/* --------------------------------------------------------------------------
 * Build array of character conses:
 * a tabulation of (:) c for each character c.
 * ------------------------------------------------------------------------*/


static Cell consCharArray[NUM_LAT1_CHARS];

Cell consChar(c)                        /* return application (:) c        */
Char c; {
    assert(c >= 0);
    return consCharArray[c];
}

static void local initConsCharTable() {
    Int i;

    for (i=0; i<NUM_LAT1_CHARS; ++i)
	consCharArray[i] = ap(nameCons,mkChar(i));
}

static void local markConsCharTable() {
    Int i;

    for (i=0; i<NUM_LAT1_CHARS; ++i)
	mark(consCharArray[i]);
}


Void charOps(what)
Int what; {
    switch (what) {
	case INSTALL : initCharTab();
		       initConsCharTable();
		       break;

	case MARK    : markConsCharTable();
		       break;

    }
}
