1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
#include <HsFFI.h>
#include <lua.h>
#include <lauxlib.h>
#include "hslexport.h"
#include "hslcall.h"
#include "hsludata.h"
/* ***************************************************************
* Transforming Haskell errors to Lua errors
* ***************************************************************/
static void hslua_pushhaskellerr(lua_State *L)
{
lua_getfield(L, LUA_REGISTRYINDEX, HSLUA_ERR);
}
/*
** Marks the occurence of an error; the returned value should be
** used as the error message.
*/
int hslua_error(lua_State *L)
{
hslua_pushhaskellerr(L);
lua_insert(L, -2);
return 2;
}
/*
** Checks whether the object at the given index is a Haskell error.
*/
static int hslua_is_haskell_error(lua_State *L, int idx)
{
int erridx = lua_absindex(L, idx);
hslua_pushhaskellerr(L);
int is_err = lua_rawequal(L, erridx, -1);
lua_pop(L, 1); /* pop haskellerr used for equality test */
return is_err;
}
/*
** Converts a Haskell function into a CFunction.
**
** We signal an error on the haskell side by passing two values:
** the special HSLUA_ERR object and the error message. The
** function returned an error iff there are exactly two results
** objects where the first object is the special HSLUA_ERR
** registry entry.
*/
int hslua_call_hs(lua_State *L)
{
int nargs = lua_gettop(L);
/* Push HaskellFunction and call the underlying function */
lua_pushvalue(L, lua_upvalueindex(1));
lua_insert(L, 1);
lua_call(L, nargs, LUA_MULTRET);
/* Check whether an error value was returned */
int nres = lua_gettop(L);
/* If there are two results, the first of which is the special
* error object, then the other object is thrown as an error.
*/
if (nres == 2 && hslua_is_haskell_error(L, 1)) {
return lua_error(L); /* throw 2nd return value as error */
}
return nres;
}
/*
** Retrieves a HsStablePtr pointer to a Haskell function from a
** function-wrapping userdata and removes the userdata from the
** stack. This will be used when the userdata is being called as a
** function.
*/
void *hslua_extracthsfun(lua_State *L)
{
void *fn = luaL_testudata(L, 1, HSLUA_HSFUN_NAME);
lua_remove(L, 1);
return fn;
}
/*
** Ensures the existence of a metatable for userdata objects that
** serve as Haskell function wrappers. If the table with name
** `HSLUA_HSFUN_NAME` does not exist yet in the registry, then
** create it, otherwise do nothing.
*/
void hslua_registerhsfunmetatable(lua_State *L)
{
if (hslua_newudmetatable(L, HSLUA_HSFUN_NAME)) {
lua_pushcfunction(L, &hslua_callhsfun);
lua_setfield(L, -2, "__call");
lua_pop(L, 1);
}
}
/*
** Creates a new C function from a Haskell function.
*/
void hslua_newhsfunction(lua_State *L, HsStablePtr fn)
{
HsStablePtr *ud = lua_newuserdata(L, sizeof fn);
*ud = fn;
luaL_setmetatable(L, HSLUA_HSFUN_NAME);
lua_pushcclosure(L, &hslua_call_hs, 1);
}
|
