/* ------------------------------------------------------------
 * tclhaskell.c --
 *
 *      Based on tkgofer.c from the TkGofer distribution.
 *      Changes by Chris Dornan (cdornan@cs.ucc.ie).
 *
 *	This file contains the interface for the "haskell-tcl" link.
 *	It is based on tkMain.c - the main program of wish.
 *
 *	It supports a new tcl-command
 *	- haskell_event n    : to write the string n into the event buffer 
 *	
 *	The provided gofer primitives are
 *	- primInitTcl 	     : to initialze tcl/tk, returns 1 if successful
 *	- primRunTcl	     : to start the eventloop of tcl/tk
 *      - primExecuteTcl     : to evaluate an event by the tcl interpreter
 *	- primGetEvent       : to read the event buffer
 *                             buffer contains event identification
 *                             plus bind arguments
 *      - primSetVar         : write user output into tcl variables
 *     
------------------------------------------------------------ */

#include <stdio.h>
#include <stdlib.h>

#include <tcl.h>
#include <tk.h>

#include <sys/types.h>
#include <sys/stat.h>

 
#include "tclhaskell.h"


void  primPutEnv(char *str)
{
  char *cpy = malloc(strlen(str)+1);
 
  if (str!=NULL) {
    strcpy(cpy,str);
    putenv(cpy);
  }
}
 
 
 
/* ------------------------------------------------------------
* Declaration for debug information
------------------------------------------------------------ */

Bool tcl_debug=0;   /* TRUE  => show debug information */


/* ------------------------------------------------------------
 * Declaration for window and interpreter variables 
------------------------------------------------------------ */

static Tcl_Interp *interp;	        /* Interpreter for this application. */

#define BUFFER_SIZE 2000  	        /* Buffers for communication 
					   Contains identifier and
					   bind arguments
				         */

#define QUEUE_SLOTS 20                  /* The number of slots in the buffer */

int queue_head=0, queue_tail=0, queue_full=0; /* The head, tail and full flag of
					   the event queue, organised as a
					   cyclic buffer
				         */

static char event_buffer[BUFFER_SIZE];   /* the event buffer */


/* ------------------------------------------------------------
 * Reporting Errors
------------------------------------------------------------ */

void tkh_error(char *message)
{
  fprintf(stderr, "TclHaskell: %s\n", message);
}

void tkh_abort(char *message)
{
  tkh_error(message);
  abort();
}


/* ------------------------------------------------------------
 * Buffer manipulation functions
------------------------------------------------------------ */

static int slot_size(void)
{
  return (BUFFER_SIZE/QUEUE_SLOTS);
}

static int slot_base(int i)
{
  return (i*slot_size());
}

static void inc_index(int *i)
{
  *i= (*i+1) % QUEUE_SLOTS;
}

static void init_queue(void)
{
  queue_head= queue_tail= queue_full= 0;
}

static int queue_empty(void)
{
  return (!queue_full && queue_head==queue_tail);
}

static void enqueue(char *str)
{
  if (str[0]==0) {
    tkh_error("empty event string");
    return;
  }
  if (strlen(str)+1>slot_size()) {
    tkh_error("event string too large");
    return;
  }
  if (queue_full) {
    tkh_error("event buffer overrun");
    return;
  }
  strcpy(event_buffer+slot_base(queue_tail), str);
  inc_index(&queue_tail);
  if (queue_head==queue_tail)
    queue_full= 1;
}

static char *dequeue(void)
{
  char *item = event_buffer+slot_base(queue_head);

  if (queue_empty())
    tkh_abort("empty queue");
  
  inc_index(&queue_head);
  queue_full= 0;
  return item;
}


/* ------------------------------------------------------------
 *  haskellEventCmd: 
 *    (Registered as a new Tcl command: see initTcl, below.)
 *
 *    This is used as part of the callback mechanism: it inserts
 *    argument string into the TclHaskell event queue, triggering
 *    primRunTcl to break its loop so that TclHaskell can retrieve
 *    the event descriptor woth primGetEvent.
------------------------------------------------------------ */

static int haskellEventCmd(dummy, interp, argc, argv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int argc;                           /* Number of arguments. */
    char **argv;                        /* Argument strings. */
{

    if (tcl_debug) {
        fprintf(stderr, "[Queueing Event: %s]\n", argv[1]);
    }

    /* ignore surplus arguments as passed to scale commands, for example */

    if (argc<2){
        Tcl_AppendResult(interp,
			 "haskellEvent: should have at least 1 argument",
			 (char *) NULL);
        return TCL_ERROR;
    }
    enqueue(argv[1]);

    return TCL_OK;
}


/* ------------------------------------------------------------
 *  Implementation of Haskell Primitives 
------------------------------------------------------------ */



/* ------------------------------------------------------------
 *  primTclDebug: 
 *    sets the debug flag
------------------------------------------------------------ */

void primTclDebug (int flg)
{
  tcl_debug = flg;
}


/* ------------------------------------------------------------
 *  primInitTcl: 
 *    initializes Tcl/Tk,
 *    and the new new command `haskellEvent',
 *    return 1 if successful, 0 otherwise.
------------------------------------------------------------ */

int primInitTcl (void) {


    if (tcl_debug) {
        fprintf(stderr, "[Initialize Tcl]\n");fflush(stderr);
    }

    init_queue();          /* Reset commuication buffers */

    interp = Tcl_CreateInterp();

    Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);

    if (Tcl_Init(interp) == TCL_ERROR) {
	fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));fflush(stderr);
	return(0);
    }

    if (Tk_Init(interp) == TCL_ERROR) {
	fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));fflush(stderr);
	return(0);
    }


    /* Extensions for tcl: */

    Tcl_CreateCommand(interp, "haskellEvent", (Tcl_CmdProc*)&haskellEventCmd, 
		      (ClientData) NULL, NULL);

    return(1);
}



/* ------------------------------------------------------------
 *  primRunTcl:
 *    runs Tcl's event loop until one or more events
 *    are queued for Haskell processing, returning 1
 *    if `.' has been destroyed, 0 otherwise.
------------------------------------------------------------ */

int primRunTcl (void) {

    if (tcl_debug) {
   	fprintf(stderr, "[TclHaskell is waiting for an event...]\n");
	fflush(stderr);
    }

    while ((Tk_GetNumMainWindows() > 0) && (queue_empty())) {
      Tcl_DoOneEvent(0);
    }
    return (Tk_GetNumMainWindows() > 0);
}

/* ------------------------------------------------------------
 * primRunNonBlockingTcl
 *
 * run tcl in a non blocking manner until we find a haskell event 
 * to perform, or there are no more windows or there are no events
 * on the tcl_tk event queue
 * returns 1 if we processed any events, otherwise 0
---------------------------------------------------------------*/

int primRunNonBlockingTcl (void) {
    Bool anyevents = 1;

    if (tcl_debug) {
   	fprintf(stderr, "[TclHaskell is checking for an event...]\n");
	fflush(stderr);
    }
    while ((Tk_GetNumMainWindows() > 0) && (queue_empty()) && anyevents) {
      anyevents = Tcl_DoOneEvent(TCL_DONT_WAIT);
    }
    return (anyevents);
}

/* ------------------------------------------------------------
 * primRunOnceTcl
 *
 * handle the first event on the tcl event queue. If there was an
 * event return 1 otherwise immediately return 0
---------------------------------------------------------------*/

int primRunOnceTcl (void) {
    if (tcl_debug) {
   	fprintf(stderr, "[TclHaskell is checking once for an event...]\n");
	fflush(stderr);
    }
    return (Tcl_DoOneEvent(TCL_DONT_WAIT));
}

/* ------------------------------------------------------------
 * primCheckAnyWindowTcl
 *
 * returns 1 if there are any tcl windows remaining and 2 otherwise
---------------------------------------------------------------*/

int primCheckAnyWindowsTcl (void) {
    return (Tk_GetNumMainWindows() > 0);
}

/* ------------------------------------------------------------
 *  primExecuteTcl:
 *    perform Tcl command and return result to TclHaskell
------------------------------------------------------------ */

static char *executeTcl (char *cmd);

char *primExecuteTcl (char *cmd)
{
  char *result;

  result= executeTcl(cmd);
  if (tcl_debug) {
    fprintf(stderr, "  %s <- %s\n", result,cmd);
    fflush(stderr);
  }
  return result;
}

void primExecuteTcl_ (char *cmd)
{
  (void) executeTcl(cmd);
  if (tcl_debug) {
    fprintf(stderr, "  %s\n", cmd);
    fflush(stderr);
  }
}

static char *executeTcl (char *cmd) 
{
   if (Tcl_Eval(interp,cmd) != TCL_OK) {
       fprintf(stderr, "Tk/Tcl: %s\n", Tcl_GetStringResult(interp));
       fflush(stderr);
       return ("");
   }
   return (Tcl_GetStringResult(interp));
} 



/* ------------------------------------------------------------
 *  primGetEvent:
 *    return the event buffer to gofer
------------------------------------------------------------ */

char *primGetEvent(void) {
  if (queue_empty()) {
    return ("");
  }
  else {
    char *item = dequeue();
      
    if (tcl_debug) {
      fprintf (stderr, "[Processing event %s]\n", item);
      fflush(stderr);
    }

    return(item);
  }
}



/* ------------------------------------------------------------
 *  primSetVar:
 *    write user output in tcl variable
 *    in this way, special tcl characters 
 *    like [, $, } etc. are irrelevant for tcl.
------------------------------------------------------------ */

void primSetVar(char *varname, char *inp) 
{
    if (tcl_debug) {
       fprintf(stderr, "set %s %s\n", varname, inp);
       fflush(stderr);
    }
    Tcl_SetVar(interp, varname, inp, TCL_GLOBAL_ONLY); 
}


char
readCharOffAddr ( void* arg1, int arg2 )
{
 return (((char*)arg1)[(int)arg2]);
}

void
writeCharOffAddr ( void* arg1, int arg2, char arg3 )
{  ((char*)arg1)[arg2]=arg3; }

void*
primMalloc(unsigned long arg1)
{
  return (void*)malloc(arg1);
}

void
primFree(void* arg1)
{ free(arg1); }
