# -*- tcl -*-
##
# (c) 2017 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
#                          http://core.tcl.tk/akupries/
##
# This code is BSD-licensed.

# # ## ### ##### ######## #############
## Tcl_ObjType for SCR-based Unicode Char Classes
## (See c_unicode.tcl for definitions)

## Core API Functions
#
##   void free (Tcl_Obj* o)                  - Release IntRep
##   void dup  (Tcl_Obj* src, Tcl_Obj* dst)  - Dup IntRep of src into dst (refcount ?)
##   void str  (Tcl_Obj* o)                  - Generate StrRep from IntRep
##   int  from (Tcl_Interp* ip, Tcl_Obj* o)  - Generate IntRep from StrRep
# 
##   Tcl_ObjType ...
# 
## User Constructor, Accessor Functionality
# 
##   int marpatcl_get_otscr_from_obj (Tcl_Obj* o, OTSCR** otscrPtr) - Retrieve OTSCR from Tcl_Obj
##   ... marpatcl_new_otscr_obj (Tcl_Obj* o, OTSCR* otscr)          - Wrap OTSCR into Tcl_Obj (+1 ref)
#
## CriTcl Glue
#
## - cproc argument type
## - cproc result type

critcl::iassoc::def marpatcl_unicontext {} {
    Tcl_ObjType*     listType;
    Tcl_ObjType*     intType;
} {
    Tcl_Obj* lst;
    Tcl_Obj* elt;

    elt = Tcl_NewIntObj(0);
    data->intType = elt->typePtr;

    lst = Tcl_NewListObj (1, &elt);
    data->listType = lst->typePtr;
    Tcl_DecrRefCount (lst);
} {
    /* nothing to do */
}

critcl::ccode {
    #define INT_REP       internalRep.otherValuePtr
    #define OTSCR_REP(o) ((OTSCR*) (o)->INT_REP)

    /*
    // The structure we use for the int rep
    */
    
    typedef struct OTSCR {
	int  refCount; /* Counter indicating sharing status of the structure */
	SCR* scr;      /* Actual intrep */
    } OTSCR;

    /*
    // Helper functions for intrep lifecycle and use.
    */
    
    OTSCR*
    marpatcl_otscr_new (SCR* scr)
    {
	OTSCR* otscr;
	TRACE_FUNC ("((SCR*) %p (elt %d))", scr, scr->n);

	otscr = (OTSCR*) ckalloc (sizeof (OTSCR));
	TRACE ("NEW otscr  = %p (rc=0) [%d]", otscr, sizeof (OTSCR));

	otscr->refCount = 0;
	otscr->scr = scr;

	TRACE_RETURN ("(OTSCR*) %p", otscr);
    }

    void
    marpatcl_otscr_destroy (OTSCR* otscr)
    {
	TRACE_FUNC ("((OTSCR*) %p (rc %d, scr %p))",
		    otscr, otscr->refCount, otscr->scr);
	
	marpatcl_scr_destroy (otscr->scr);

	TRACE ("DEL (OTSCR*) %p", otscr);
	ckfree((char*) otscr);

	TRACE_RETURN_VOID;
    }

    OTSCR*
    marpatcl_otscr_take (OTSCR* otscr)
    {
	TRACE_FUNC ("((OTSCR*) %p)", otscr);

	otscr->refCount ++;
	TRACE ("(OTSCR*) %p (rc=%d)", otscr, otscr ? otscr->refCount : -5);
	TRACE_RETURN ("(OTSCR*) %p", otscr);
    }
    
    void
    marpatcl_otscr_release (OTSCR* otscr)
    {
	TRACE_FUNC ("(OTSCR*) %p)", otscr);

	otscr->refCount --;
	TRACE ("(OTSCR*) %p (rc=%d)", otscr, otscr ? otscr->refCount : -5);

	if (otscr->refCount > 0) {
	    TRACE_RETURN_VOID;
	}

	marpatcl_otscr_destroy (otscr);
	TRACE_RETURN_VOID;
    }

    /*
    // Helper macro for dealing with Tcl_ObjType's.
    */

    #undef  FreeIntRep
    #define FreeIntRep(objPtr) \
	if ((objPtr)->typePtr != NULL && \
		(objPtr)->typePtr->freeIntRepProc != NULL) { \
	    (objPtr)->typePtr->freeIntRepProc(objPtr); \
	    (objPtr)->typePtr = NULL; \
	}

    /*
    // Forward declare the type structure
    */
    
    static Tcl_ObjType marpatcl_scr_objtype;

    /*
    // Tcl_ObjType vectors implementing it
    */
    
    static void
    marpatcl_scr_rep_free (Tcl_Obj* o)
    {
	TRACE_FUNC ("(o %p (rc %d))", o, o->refCount);
	TRACE ("(OTSCR*) %p (rc=%d)", OTSCR_REP(o), OTSCR_REP(o)->refCount);
	TRACE ("(SCR*) %p", OTSCR_REP(o)->scr);

	marpatcl_otscr_release (OTSCR_REP(o));

	TRACE_RETURN_VOID;
    }
    
    static void
    marpatcl_scr_rep_dup (Tcl_Obj* src, Tcl_Obj* dst)
    {
	TRACE_FUNC ("(src %p (rc=%d), dst %p)",
		    src, src ? src->refCount : -5, dst);
	
	marpatcl_otscr_take (OTSCR_REP(src));
	dst->INT_REP = src->INT_REP;
	dst->typePtr = &marpatcl_scr_objtype;

	TRACE_RETURN_VOID;
    }
    
    static void
    marpatcl_scr_rep_str (Tcl_Obj* o)
    {
	/*
	// Generate a string for a list, using the CC as basis.
	// We ensure that the CC is canonical first.
	*/
	char        buf [20];
	SCR*        scr = OTSCR_REP(o)->scr;
	Tcl_DString ds;
	int         i;
	CR*         cr;

	TRACE_FUNC ("(o %p (rc=%d))", o, o->refCount);
	TRACE ("(OTSCR*) %p (rc=%d)", OTSCR_REP(o), OTSCR_REP(o)->refCount);
	TRACE ("(SCR*) %p", OTSCR_REP(o)->scr);

	marpatcl_scr_norm (scr);
	Tcl_DStringInit (&ds);

	for (cr = &scr->cr[0], i = 0;
	     i < scr->n;
	     i++, cr++) {
	    if (cr->start == cr->end) {
		/* range is single element */
		sprintf(buf, "%d", cr->start); 
		Tcl_DStringAppendElement (&ds, buf);
	    } else {
		/* actual range */
		Tcl_DStringStartSublist(&ds);
		sprintf(buf, "%d", cr->start); 
		Tcl_DStringAppendElement (&ds, buf);
		sprintf(buf, "%d", cr->end); 
		Tcl_DStringAppendElement (&ds, buf);
		Tcl_DStringEndSublist(&ds);
	    }
	}

	STREP_DS (o, &ds);

	Tcl_DStringFree (&ds);
	TRACE_RETURN_VOID;
    }

    static int
    marpatcl_scr_bad_codepoint (Tcl_Interp* ip, const char* msg, int codepoint) {
	char buf [100];
	if ((codepoint >= 0) &&
	    (codepoint <= UNI_MAX)) {
	    return 0;
	}
	sprintf (buf, "%s out of range (0...%d): %d",
		 msg, UNI_MAX, codepoint);
	Tcl_SetErrorCode (ip, "MARPA", NULL);
	Tcl_SetObjResult (ip, Tcl_NewStringObj(buf,-1));
	return 1;
    }
    
    static int
    marpatcl_scr_bad_range (Tcl_Interp* ip, int start, int end) {
	char buf [100];
	if (start <= end) {
	    return 0;
	}
	sprintf (buf, "Range empty (end (%d) before start (%d))",
		 start, end);
	Tcl_SetErrorCode (ip, "MARPA", NULL);
	Tcl_SetObjResult (ip, Tcl_NewStringObj(buf,-1));
	return 1;
    }
    
    static int
    marpatcl_scr_rep_from_any (Tcl_Interp* ip, Tcl_Obj* o)
    {
	/*
	// The conversion goes through a list intrep, avoiding manual
	// parsing of the structure.
	*/
	int       objc;
	Tcl_Obj **objv;
	int       robjc;
	Tcl_Obj **robjv;
	SCR*      scr   = NULL;
	OTSCR*    otscr = NULL;
	int       start, end, i;
	marpatcl_unicontext_data ctx =  marpatcl_unicontext (ip);

	TRACE_FUNC ("(ip %p, o %p)", ip, o);
	/*
	// The class is a list of codepoints and ranges (2-element lists).
	*/
	if (Tcl_ListObjGetElements(ip, o, &objc, &objv) != TCL_OK) {
	    goto fail;
	}

	scr = marpatcl_scr_new (objc);
	TRACE ("CAP %d", objc);
	for (i = 0; i < objc; i++) {
	    Tcl_Obj* elt = objv[i];
	    TRACE ("PROCESS. [%02d] %p", i, elt);
	    
	    /*
	    // First handle objects which already have a suitable type.
	    // No conversions required, only data extraction and validation.
	    */

	    if (elt->typePtr == ctx->intType) {
		TRACE ("INT. ... [%02d] %p", i, elt);
		Tcl_GetIntFromObj(ip, elt, &start);

	    process_int:
		TRACE ("INT. CHK [%02d] %p", i, elt);
		if (marpatcl_scr_bad_codepoint (ip, "Point", start)) {
		    goto fail;
		}
		TRACE ("++ (%d)", start);
		marpatcl_scr_add_range(scr, start, start);
		continue;

	    }

	    if (elt->typePtr == ctx->listType) {
		TRACE ("LIST ... [%02d] %p", i, elt);
		Tcl_ListObjGetElements(ip, elt, &robjc, &robjv);

	    process_list:
		TRACE ("LIST CHK [%02d] %p", i, elt);
		if (robjc != 2) {
	    #define MSG "Expected 2-element list for range"
		    Tcl_SetErrorCode (ip, "MARPA", NULL);
		    Tcl_SetObjResult (ip, Tcl_NewStringObj(MSG,-1));
		    goto fail;
	    #undef MSG
		}
		if ((Tcl_GetIntFromObj (ip, robjv[0], &start) != TCL_OK) ||
		    marpatcl_scr_bad_codepoint (ip, "Range (start)", start) ||
		    (Tcl_GetIntFromObj (ip, robjv[1], &end) != TCL_OK) ||
		    marpatcl_scr_bad_codepoint (ip, "Range (end)", end) ||
		    marpatcl_scr_bad_range(ip, start, end)) {
		    goto fail;
		}
		TRACE ("++ (%d...%d)", start, end);
		marpatcl_scr_add_range(scr, start, end);
		continue;
	    }

	    /*
	    // While object has no suitable type, it may be
	    // convertible to such. Those which are convertable get
	    // dispatched to the handlers above.
	    */

	    if (Tcl_GetIntFromObj(ip, elt, &start) == TCL_OK) {
		TRACE ("INT. CVT [%02d] %p", i, elt);
		goto process_int;
	    }

	    if (Tcl_ListObjGetElements(ip, elt, &robjc, &robjv) == TCL_OK) {
		TRACE ("LIST CVT [%02d] %p", i, elt);
		goto process_list;
	    }

	    TRACE ("NO.. CVT [%02d] %p", i, elt);

	    /*
	    // No suitable type, and not convertible to such either.
	    // Most of the time this is not reached because most bogus
	    // input is convertible to a list. And then the range-validation
	    // kicks in. Only bad list syntax comes here.
	    */

	    Tcl_SetErrorCode (ip, "MARPA", NULL);
	    Tcl_SetObjResult (ip, Tcl_NewStringObj("Expected codepoint or range, got neither",-1));
	    goto fail;
	}

	TRACE ("USE %d", scr->n);
	
	otscr = marpatcl_otscr_take (marpatcl_otscr_new (scr));

	/*
	// Kill the old intrep (a list). This was delayed as much as
	// possible. Afterward we can put in our own intrep.
	*/

	FreeIntRep (o);

	o->INT_REP = otscr;
	o->typePtr = &marpatcl_scr_objtype;

	TRACE_RETURN ("ok: %d", TCL_OK);

    fail:
	TRACE ("%s", "FAIL");
	if (scr) {
	    marpatcl_scr_destroy(scr);
	}
	TRACE_RETURN ("err: %d", TCL_ERROR);
    }
    
    static Tcl_ObjType marpatcl_scr_objtype = {
	"marpa::cc::scr",
	marpatcl_scr_rep_free,
	marpatcl_scr_rep_dup,
	marpatcl_scr_rep_str,
	marpatcl_scr_rep_from_any
    };

    /* Public creator/accessor functions
    */

    Tcl_Obj*
    marpatcl_new_otscr_obj (OTSCR* otscr)
    {
	Tcl_Obj* obj;
	TRACE_FUNC ("((OTSCR*) %p)", otscr);
	obj = Tcl_NewObj ();
	TRACE ("(Tcl_Obj*) %p (rc=%d)", obj, obj->refCount);
	
	Tcl_InvalidateStringRep (obj);
	obj->INT_REP = marpatcl_otscr_take (otscr);
	obj->typePtr = &marpatcl_scr_objtype;

	TRACE_RETURN ("(Tcl_Obj*) %p", obj);
    }

    int
    marpatcl_get_otscr_from_obj (Tcl_Interp* ip, Tcl_Obj* o, OTSCR** otscrPtr)
    {
	TRACE_FUNC ("(ip %p, o %p (rc=%d), oscr^ %p",
		    o, o->refCount, otscrPtr);

	if (o->typePtr != &marpatcl_scr_objtype) {
	    if (marpatcl_scr_rep_from_any (ip, o) != TCL_OK) {
		TRACE_RETURN ("ERROR", TCL_ERROR);
	    }
	}

	*otscrPtr = OTSCR_REP(o);
	TRACE ("(OTSCR*) %p (rc=%d)", *otscrPtr, (*otscrPtr)->refCount);
	TRACE_RETURN ("OK", TCL_OK);
    }
}

# # ## ### ##### ######## #############
# Glue to critcl::cproc

critcl::argtype Marpa_CharClass {
    @A = NULL;
    TRACE ("A(Marpa_CharClass): obj %p (rc=%d)", @@, @@->refCount);
    if (marpatcl_get_otscr_from_obj (interp, @@, &@A) != TCL_OK) {
	TRACE ("%s", "A(Marpa_CharClass): ERROR");
	return TCL_ERROR;
    }
    TRACE ("A(Marpa_CharClass): (OTSCR*) %p (rc=%d)", @A, @A->refCount);
    TRACE ("%s", "A(Marpa_CharClass): DONE");
} OTSCR* OTSCR*

critcl::resulttype Marpa_CharClass {
    TRACE ("R(Marpa_CharClass): (OTSCR*) %p (rc=%d)", rv, rv ? rv->refCount : -5);
    if (rv == NULL) { return TCL_ERROR; }
    Tcl_SetObjResult(interp, marpatcl_new_otscr_obj (rv));
    TRACE ("R(Marpa_CharClass): obj %p (rc=%d)", Tcl_GetObjResult(interp), Tcl_GetObjResult(interp)->refCount);
    /* No refcount adjustment */
    TRACE ("%s", "R(Marpa_CharClass): DONE");
    return TCL_OK;
} OTSCR*

# # ## ### ##### ######## #############
## API exposed to Tcl level
## Supercedes original procs in p_unicode.tcl

critcl::cproc marpa::unicode::negate-class {
    Tcl_Interp*     interp
    Marpa_CharClass charclass
} Marpa_CharClass {
    /* charclass :: OTSCR* */
    TRACE_FUNC ("((OTSCR*) %p (rc=%d))", charclass, charclass->refCount);
    TRACE ("(SCR*) %p", charclass->scr);
    charclass = marpatcl_otscr_new (marpatcl_scr_complement (charclass->scr));
    TRACE_RETURN ("(OTSCR*) %p", charclass);
}

critcl::cproc marpa::unicode::norm-class {
    Tcl_Interp*     interp
    Marpa_CharClass charclass
} Marpa_CharClass {
    /*
    // charclass :: OTSCR*
    // The deeper intrep is modified.
    // A possible string rep is not.
    */
    TRACE_FUNC ("((OTSCR*) %p (rc=%d))",
		charclass, charclass->refCount);
    TRACE ("(SCR*) %p", charclass->scr);
    marpatcl_scr_norm (charclass->scr);
    TRACE_RETURN ("(OTSCR*) %p", charclass);
}

# # ## ### ##### ######## #############
return
