/* ------------------------------------------------------------
 * tkhaskell.c --
 *
 *      Based on tkgofer.c from the TkGofer distribution.
 *      Changes by Chris Dornan (cdornan@cs.ucc.ie).
 *      Still more changes by Johan Nordlander (nordland@cs.chalmers.se)
 *
 *	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
 *	- 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
 *	- primGetTcl     : to read the event buffer
 *                         buffer contains event identification
 *                         plus bind arguments
 *      - primSetVar     : write user output into tcl variables
 *     
------------------------------------------------------------ */

#if MACWP
#define MAC_TCL
#endif

#include <stdio.h>
#include <tcl.h>
#include <tk.h>
#if O_TIX
#include <tix.h>
#endif

static Void   c_primTclDebug      Args((Int flg));
       
static Bool   c_primInitTcl       Args((Void));
static Int    c_primRunTcl        Args((Void));
static String c_primExecuteTcl    Args((char *cmd));
static Void   c_primExecuteTcl_   Args((char *cmd));
static String c_primGetTcl        Args((Void));
static Void   c_primSetVar        Args((String,String));

static String executeTcl          Args((String ));
static Void   c_reset_com         Args((Void));
static Void   c_deleteTcl         Args((Void));
static Void   c_checkDeleteTcl    Args((Void));

Int EventCmd                      Args((ClientData,Tcl_Interp *,Int,String *));


/* ------------------------------------------------------------
* Declaration for debug information
------------------------------------------------------------ */

Bool tk_debug = FALSE;   /* TRUE  => show debug information */


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

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

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

static char to_gofer[BUFFER_SIZE+1];	/* events: tk to gofer */

static Bool stopTkMain = TRUE;

static Bool tclRunning = FALSE;

/* ------------------------------------------------------------
 * Declaration for new Tcl command procedures 
------------------------------------------------------------ */

extern int EventCmd _ANSI_ARGS_((ClientData clientData,
        Tcl_Interp *interp, int argc, char *argv[]));

/* ------------------------------------------------------------
 *  EventCmd: 
 *    puts the argument string into the to_gofer buffer,
 *    resets the to_gofer_ct, (see c_get_tcl)
 *    terminates the MainLoop - can be restarted using c_run_tcl
------------------------------------------------------------ */

int EventCmd(dummy, interp, argc, argv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    Int argc;                           /* Number of arguments. */
    String *argv;                       /* Argument strings. */
{
    Int i;

    to_gofer[0]   = '\0';
    for (i=1;i<argc;i++) {
          strcat(to_gofer,argv[i]);
          strcat(to_gofer," ");
    }

    stopTkMain = TRUE; /* Stop the event loop */

    return TCL_OK;
}



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


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

Void c_primTclDebug (flg)
Bool flg; {
  tk_debug = flg;
    if (tk_debug) {
        fprintf(stderr, "### Running in debug mode\n");
        fprintf(stderr,"proc doEvent {ev args} {}\n");
        fprintf(stderr,"wm withdraw .\n");
    }
}


/* ------------------------------------------------------------
 *  primInitTcl: 
 *    initialize tcl/tk, i.e. creates the main window ,
 *    initializes the standard tcl/tk package 
 *    and the new new command `event',
 *    load extra tcl/tk sources
 *    return TRUE if successful, FALSE otherwise
------------------------------------------------------------ */

static Int c_primInitTcl () { 


    if (tk_debug) {
        fprintf(stderr, "###[Initialize Tk (4.1 or higher)]\n");
    }

    c_reset_com();          /* Reset commuication buffers */

#if CYGWIN
    setenv("TCL_LIBRARY","c:/cygwin/usr/share/tcl8.0",0);

    Tcl_FindExecutable(gArgv[0]);
#endif

    interp = Tcl_CreateInterp();


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

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

    if (Tk_Init(interp) == TCL_ERROR) {
	fprintf(stderr, "%s\n", interp->result);
	return FALSE;
    }
#if O_TIX
    if (Tix_Init(interp) == TCL_ERROR) {
	fprintf(stderr, "%s\n", interp->result);
	return FALSE;
    }
#endif

    /* Extensions for tcl: */

    Tcl_CreateCommand(interp, "haskellEvent", EventCmd, (ClientData) NULL,
                      NULL);

    c_primExecuteTcl_("proc doEvent {ev args} {haskellEvent $ev $args}");
    c_primExecuteTcl_("proc internalError {args} {global tk_version\nif {\"$tk_version\" == \"4.1\" } {bgerror $args} else {tkerror $args}}");
    c_primExecuteTcl_("wm withdraw .");

    tclRunning = TRUE;           /* initialization succeeded */
    

    return TRUE;
}



/* ------------------------------------------------------------
 *  primRunTcl:
 *    starts tk to handle events
 *    terminates if user interface is destroyed
 *    (Tk_GetNumMainWinows == 0) or after an event is
 *    handled  (stopTkMain == TRUE)
 *    returns FALSE if no more windows (*** CBD ***)
------------------------------------------------------------ */

static Bool c_primRunTcl () {

    if (tk_debug) {
   	fprintf(stderr, "### Tk is waiting for an event...\n");
    }

    stopTkMain = FALSE;

    while ((Tk_GetNumMainWindows() > 0) && (stopTkMain == FALSE)) {
      Tk_DoOneEvent(0);
    }
    
    return (Tk_GetNumMainWindows() > 0);
}



/* ------------------------------------------------------------
 *  primExecuteTcl:
 *    perform action and return result to ohugs
------------------------------------------------------------ */

static String c_primExecuteTcl (cmd)
String cmd; {
  String result;
  if (tk_debug) fprintf(stderr, "%s\n", cmd);
  result= executeTcl(cmd);
  if (tk_debug) fprintf(stderr, "### Reply: %s\n", result);
  return result;
}

static Void c_primExecuteTcl_ (cmd)
String cmd; {
  if (tk_debug) fprintf(stderr, "%s\n", cmd);
  (Void) executeTcl(cmd);
}

static String executeTcl (cmd) 
String cmd; {
   char errmsg[200];
   if (Tcl_Eval(interp,cmd) != TCL_OK) {
       fprintf(stderr, "###Tk/Tcl: %s\n", interp->result);
       strcpy(errmsg,"###internalError {");
       strcat (errmsg,interp -> result);
       strcat (errmsg, " }");
       if (Tcl_Eval(interp,errmsg) != TCL_OK){
         fprintf(stderr, "###%s\n", interp->result);
         exit(1);
         return ("");
       }
   }
   return (interp -> result);
} 



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

static String c_primGetTcl () {
     if (tk_debug) {
           fprintf (stderr, "### Event: %s\n", to_gofer);
     }
     return to_gofer;
}



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

static Void c_primSetVar (varname,inp) 
String varname;
String inp; {
    if (tk_debug) {
       fprintf(stderr, "set %s %s\n", varname, inp);
    }
    Tcl_SetVar(interp, varname, inp, TCL_GLOBAL_ONLY); 
}

primFun(primTclDebug) {
    eval(primArg(3));
    if (whnfHead==nameTrue) {
        c_primTclDebug(1);}
    else {
        c_primTclDebug(0);}
    updapRoot(primArg(1),nameUnit);
}

primFun(primInitTcl) {			/* initialize tcl/tk               */
    					/*  :: Cmd Bool	         	   */
    updapRoot(primArg(1),c_primInitTcl() ? nameTrue : nameFalse);
}

primFun(primRunTcl) {			/* start eventloop of tcl/tk       */
    					/*  :: Cmd Bool			   */

    updapRoot(primArg(1),c_primRunTcl() ?  nameTrue : nameFalse);
}

primFun(primExecuteTcl) {   		/* evaluate string in tk           */
    Cell es = primArg(3);		/*  :: String -> Cmd String        */

    String inp;
    String out;

    inp = evalName(es);

    out = c_primExecuteTcl(inp);

    updapRoot(primArg(1),buildString(out));
}

primFun(primExecuteTcl_) {   		/* evaluate string in tk           */
    Cell es = primArg(3);		/*  :: String -> Cmd ()            */
    String inp;

    inp = evalName(es);
    c_primExecuteTcl_(inp);

    updapRoot(primArg(1),nameUnit);
}

primFun(primGetTcl) {			/* get character from event buffer */
     					/*  :: Cmd String		   */
    String out = c_primGetTcl();

    updapRoot(primArg(1),buildString(out));
}

primFun(primSetVar) {   		/* put string in tcl variable      */
                       		  	/*  :: String -> String -> Cmd ()  */
    String val = evalName(primArg(3));  /*  eval variable contents         */
    String vari = evalName(primArg(4)); /*  eval variable name             */

    c_primSetVar(vari,val);

    updapRoot(primArg(1),nameUnit);
}

primFun(primGetPath) {                   /* generate tk path suffix */
                                         /* :: Cmd String           */
    char newpath[50];

    sprintf(newpath,".@%i",tkpath++);
    updapRoot(primArg(1),buildString(newpath));
}

primFun(primAddCallBack) {                /* store callback action                */
    Cell cb = primArg(3);                 /* :: (String -> Action) -> Request Int */
    callbacks = cons(cb,callbacks);
    nrcallbacks++;
    updapRoot(primArg(1),mkInt(nrcallbacks));
}

primFun(primNextCallBack) {                /* index of first free callback                */
    updapRoot(primArg(1),mkInt(nrcallbacks+1));
}



/* ------------------------------------------------------------
 *  Subroutines
------------------------------------------------------------ */


/* ------------------------------------------------------------
 *  c_reset_com:
 *    resets global communication buffers
------------------------------------------------------------ */

static Void c_reset_com () {
    to_gofer[0]   = '\0';
}

#ifdef Bool
#  undef Bool /* Clash with our definition */
#endif



static Void c_deleteTcl () {
   if(tk_debug)
     fprintf(stderr, "Tcl_DeleteInterp\n");
   Tcl_DeleteInterp(interp);
   tclRunning = FALSE;
}

static Void c_checkDeleteTcl () {
  if(tclRunning) {
     c_deleteTcl();
  }
}