/* ------------------------------------------------------------
* 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();
}
}
syntax highlighted by Code2HTML, v. 0.9.1