module Scripting.Lua
(
LuaState(..),
LuaCFunction,
LuaInteger,
LuaNumber,
LuaImport(..),
GCCONTROL(..),
LTYPE(..),
multret,
registryindex,
environindex,
globalsindex,
atpanic,
call,
checkstack,
close,
concat,
cpcall,
createtable,
dump,
equal,
gc,
--getallocf,
getfenv,
getfield,
getglobal,
--gethook,
--gethookcount,
--gethookmask,
--getinfo,
--getlocal,
getmetatable,
--getstack,
gettable,
gettop,
getupvalue,
insert,
isboolean,
iscfunction,
isfunction,
islightuserdata,
isnil,
isnumber,
isstring,
istable,
isthread,
isuserdata,
lessthan,
--load,
newstate,
newtable,
newthread,
newuserdata,
next,
objlen,
pcall,
pop,
pushboolean,
pushcclosure,
pushcfunction,
--pushfstring,
pushinteger,
pushlightuserdata,
--pushlstring,
pushnil,
pushnumber,
pushstring,
pushthread,
pushvalue,
--pushvfstring,
rawequal,
rawget,
rawgeti,
rawset,
rawseti,
register,
remove,
replace,
resume,
--setallocf,
setfenv,
setfield,
setglobal,
--sethook,
--setlocal,
setmetatable,
settable,
settop,
setupvalue,
status,
toboolean,
tocfunction,
tointeger,
--tolstring,
tonumber,
topointer,
tostring,
tothread,
touserdata,
ltype,
typename,
upvalueindex,
xmove,
yield,
openlibs,
loadfile,
loadstring,
newmetatable,
argerror,
ref,
unref,
StackValue(..),
callproc,
callfunc,
getglobal2,
newcfunction,
freecfunction,
luaimport,
pushhsfunction,
pushrawhsfunction,
registerhsfunction,
registerrawhsfunction
)
where
import Prelude hiding (concat, catch)
import Foreign.C
import Foreign.Ptr
import Foreign.StablePtr
import Control.Monad
import Control.Exception
import Foreign.Marshal.Alloc
import Data.IORef
import qualified Foreign.Storable as F
import qualified Data.List as L
import Data.Maybe
newtype LuaState = LuaState (Ptr ())
type LuaAlloc = Ptr () -> Ptr () -> CSize -> CSize -> IO (Ptr ())
type LuaReader = Ptr () -> Ptr () -> Ptr CSize -> IO (Ptr CChar)
type LuaWriter = LuaState -> Ptr CChar -> CSize -> Ptr () -> IO CInt
type LuaCFunction = LuaState -> IO CInt
type LuaInteger = CPtrdiff
type LuaNumber = CDouble
data LTYPE = TNONE
| TNIL
| TBOOLEAN
| TLIGHTUSERDATA
| TNUMBER
| TSTRING
| TTABLE
| TFUNCTION
| TUSERDATA
| TTHREAD
deriving (Eq,Show,Ord)
instance Enum LTYPE where
fromEnum TNONE = 1
fromEnum TNIL = 0
fromEnum TBOOLEAN = 1
fromEnum TLIGHTUSERDATA = 2
fromEnum TNUMBER = 3
fromEnum TSTRING = 4
fromEnum TTABLE = 5
fromEnum TFUNCTION = 6
fromEnum TUSERDATA = 7
fromEnum TTHREAD = 8
toEnum (1) = TNONE
toEnum (0) = TNIL
toEnum (1) = TBOOLEAN
toEnum (2) = TLIGHTUSERDATA
toEnum (3) = TNUMBER
toEnum (4) = TSTRING
toEnum (5) = TTABLE
toEnum (6) = TFUNCTION
toEnum (7) = TUSERDATA
toEnum (8) = TTHREAD
toEnum n = error $ "Cannot convert (" ++ show n ++ ") to LTYPE"
data GCCONTROL = GCSTOP
| GCRESTART
| GCCOLLECT
| GCCOUNT
| GCCOUNTB
| GCSTEP
| GCSETPAUSE
| GCSETSTEPMUL
deriving (Eq,Ord,Show,Enum)
multret :: Int
multret = 1
foreign import ccall "lua.h lua_close" c_lua_close :: LuaState -> IO ()
foreign import ccall "lua.h lua_newstate" c_lua_newstate :: FunPtr LuaAlloc -> Ptr () -> IO LuaState
foreign import ccall "lua.h lua_newthread" c_lua_newthread :: LuaState -> IO LuaState
foreign import ccall "lua.h lua_atpanic" c_lua_atpanic :: LuaState -> FunPtr LuaCFunction -> IO (FunPtr LuaCFunction)
foreign import ccall "lua.h lua_gettop" c_lua_gettop :: LuaState -> IO CInt
foreign import ccall "lua.h lua_settop" c_lua_settop :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_pushvalue" c_lua_pushvalue :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_remove" c_lua_remove :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_insert" c_lua_insert :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_replace" c_lua_replace :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_checkstack" c_lua_checkstack :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_xmove" c_lua_xmove :: LuaState -> LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_isnumber" c_lua_isnumber :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_isstring" c_lua_isstring :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_iscfunction" c_lua_iscfunction :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_isuserdata" c_lua_isuserdata :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_type" c_lua_type :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_typename" c_lua_typename :: LuaState -> CInt -> IO (Ptr CChar)
foreign import ccall "lua.h lua_equal" c_lua_equal :: LuaState -> CInt -> CInt -> IO CInt
foreign import ccall "lua.h lua_rawequal" c_lua_rawequal :: LuaState -> CInt -> CInt -> IO CInt
foreign import ccall "lua.h lua_lessthan" c_lua_lessthan :: LuaState -> CInt -> CInt -> IO CInt
foreign import ccall "lua.h lua_tonumber" c_lua_tonumber :: LuaState -> CInt -> IO LuaNumber
foreign import ccall "lua.h lua_tointeger" c_lua_tointeger :: LuaState -> CInt -> IO LuaInteger
foreign import ccall "lua.h lua_toboolean" c_lua_toboolean :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_tolstring" c_lua_tolstring :: LuaState -> CInt -> Ptr CInt -> IO (Ptr CChar)
foreign import ccall "lua.h lua_objlen" c_lua_objlen :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_tocfunction" c_lua_tocfunction :: LuaState -> CInt -> IO (FunPtr LuaCFunction)
foreign import ccall "lua.h lua_touserdata" c_lua_touserdata :: LuaState -> CInt -> IO (Ptr a)
foreign import ccall "lua.h lua_tothread" c_lua_tothread :: LuaState -> CInt -> IO LuaState
foreign import ccall "lua.h lua_topointer" c_lua_topointer :: LuaState -> CInt -> IO (Ptr ())
foreign import ccall "lua.h lua_pushnil" c_lua_pushnil :: LuaState -> IO ()
foreign import ccall "lua.h lua_pushnumber" c_lua_pushnumber :: LuaState -> LuaNumber -> IO ()
foreign import ccall "lua.h lua_pushinteger" c_lua_pushinteger :: LuaState -> LuaInteger -> IO ()
foreign import ccall "lua.h lua_pushlstring" c_lua_pushlstring :: LuaState -> Ptr CChar -> CInt -> IO ()
foreign import ccall "lua.h lua_pushstring" c_lua_pushstring :: LuaState -> Ptr CChar -> IO ()
foreign import ccall "lua.h lua_pushcclosure" c_lua_pushcclosure :: LuaState -> FunPtr LuaCFunction -> CInt -> IO ()
foreign import ccall "lua.h lua_pushboolean" c_lua_pushboolean :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_pushlightuserdata" c_lua_pushlightuserdata :: LuaState -> Ptr a -> IO ()
foreign import ccall "lua.h lua_pushthread" c_lua_pushthread :: LuaState -> IO CInt
foreign import ccall "lua.h lua_gettable" c_lua_gettable :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_getfield" c_lua_getfield :: LuaState -> CInt -> Ptr CChar -> IO ()
foreign import ccall "lua.h lua_rawget" c_lua_rawget :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_rawgeti" c_lua_rawgeti :: LuaState -> CInt -> CInt -> IO ()
foreign import ccall "lua.h lua_createtable" c_lua_createtable :: LuaState -> CInt -> CInt -> IO ()
foreign import ccall "lua.h lua_newuserdata" c_lua_newuserdata :: LuaState -> CInt -> IO (Ptr ())
foreign import ccall "lua.h lua_getmetatable" c_lua_getmetatable :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_getfenv" c_lua_getfenv :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_getupvalue" c_lua_getupvalue :: LuaState -> CInt -> CInt -> IO (Ptr CChar)
foreign import ccall "lua.h lua_setupvalue" c_lua_setupvalue :: LuaState -> CInt -> CInt -> IO (Ptr CChar)
foreign import ccall "lua.h lua_settable" c_lua_settable :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_setfield" c_lua_setfield :: LuaState -> CInt -> Ptr CChar -> IO ()
foreign import ccall "lua.h lua_rawset" c_lua_rawset :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_rawseti" c_lua_rawseti :: LuaState -> CInt -> CInt -> IO ()
foreign import ccall "lua.h lua_setmetatable" c_lua_setmetatable :: LuaState -> CInt -> IO ()
foreign import ccall "lua.h lua_setfenv" c_lua_setfenv :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_call" c_lua_call :: LuaState -> CInt -> CInt -> IO ()
foreign import ccall "lua.h lua_pcall" c_lua_pcall :: LuaState -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "lua.h lua_cpcall" c_lua_cpcall :: LuaState -> FunPtr LuaCFunction -> Ptr a -> IO CInt
foreign import ccall "lua.h lua_load" c_lua_load :: LuaState -> FunPtr LuaReader -> Ptr () -> Ptr CChar -> IO CInt
foreign import ccall "lua.h lua_dump" c_lua_dump :: LuaState -> FunPtr LuaWriter -> Ptr () -> IO ()
foreign import ccall "lua.h lua_yield" c_lua_yield :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_resume" c_lua_resume :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_status" c_lua_status :: LuaState -> IO CInt
foreign import ccall "lua.h lua_gc" c_lua_gc :: LuaState -> CInt -> CInt -> IO CInt
foreign import ccall "lua.h lua_error" c_lua_error :: LuaState -> IO CInt
foreign import ccall "lua.h lua_next" c_lua_next :: LuaState -> CInt -> IO CInt
foreign import ccall "lua.h lua_concat" c_lua_concat :: LuaState -> CInt -> IO ()
foreign import ccall "lualib.h luaL_openlibs" c_luaL_openlibs :: LuaState -> IO ()
foreign import ccall "lauxlib.h luaL_newstate" c_luaL_newstate :: IO LuaState
foreign import ccall "lauxlib.h luaL_newmetatable" c_luaL_newmetatable :: LuaState -> Ptr CChar -> IO CInt
foreign import ccall "lauxlib.h luaL_argerror" c_luaL_argerror :: LuaState -> CInt -> Ptr CChar -> IO CInt
foreign import ccall "lauxlib.h luaL_ref" c_luaL_ref :: LuaState -> CInt -> IO CInt
foreign import ccall "lauxlib.h luaL_unref" c_luaL_unref :: LuaState -> CInt -> CInt -> IO ()
foreign import ccall "ntrljmp.h lua_neutralize_longjmp" c_lua_neutralize_longjmp :: LuaState -> IO CInt
foreign import ccall "ntrljmp.h &lua_neutralize_longjmp" c_lua_neutralize_longjmp_addr :: FunPtr (LuaState -> IO CInt)
settop :: LuaState -> Int -> IO ()
settop l n = c_lua_settop l (fromIntegral n)
createtable :: LuaState -> Int -> Int -> IO ()
createtable l s z = c_lua_createtable l (fromIntegral s) (fromIntegral z)
objlen :: LuaState -> Int -> IO Int
objlen l n = liftM fromIntegral (c_lua_objlen l (fromIntegral n))
pop :: LuaState -> Int -> IO ()
pop l n = settop l (n1)
newtable :: LuaState -> IO ()
newtable l = createtable l 0 0
pushcclosure :: LuaState -> FunPtr LuaCFunction -> Int -> IO ()
pushcclosure l f n = c_lua_pushcclosure l f (fromIntegral n)
pushcfunction :: LuaState -> FunPtr LuaCFunction -> IO ()
pushcfunction l f = pushcclosure l f 0
strlen :: LuaState -> Int -> IO Int
strlen l i = objlen l i
ltype :: LuaState -> Int -> IO LTYPE
ltype l n = liftM (toEnum . fromIntegral) (c_lua_type l (fromIntegral n))
isfunction :: LuaState -> Int -> IO Bool
isfunction l n = liftM (==TFUNCTION) (ltype l n)
istable :: LuaState -> Int -> IO Bool
istable l n = liftM (==TTABLE) (ltype l n)
islightuserdata :: LuaState -> Int -> IO Bool
islightuserdata l n = liftM (==TLIGHTUSERDATA) (ltype l n)
isnil :: LuaState -> Int -> IO Bool
isnil l n = liftM (==TNIL) (ltype l n)
isboolean :: LuaState -> Int -> IO Bool
isboolean l n = liftM (==TBOOLEAN) (ltype l n)
isthread :: LuaState -> Int -> IO Bool
isthread l n = liftM (==TTHREAD) (ltype l n)
isnone :: LuaState -> Int -> IO Bool
isnone l n = liftM (==TNONE) (ltype l n)
isnoneornil :: LuaState -> Int -> IO Bool
isnoneornil l n = liftM (<=TNIL) (ltype l n)
registryindex :: Int
registryindex = 10000
environindex :: Int
environindex = 10001
globalsindex :: Int
globalsindex = 10002
upvalueindex :: Int -> Int
upvalueindex i = globalsindex i
atpanic :: LuaState -> FunPtr LuaCFunction -> IO (FunPtr LuaCFunction)
atpanic = c_lua_atpanic
tostring :: LuaState -> Int -> IO String
tostring l n = alloca $ \lenPtr -> do
cstr <- c_lua_tolstring l (fromIntegral n) lenPtr
len <- F.peek lenPtr
peekCStringLen (cstr, fromIntegral len)
tothread :: LuaState -> Int -> IO LuaState
tothread l n = c_lua_tothread l (fromIntegral n)
touserdata :: LuaState -> Int -> IO (Ptr a)
touserdata l n = c_lua_touserdata l (fromIntegral n)
typename :: LuaState -> LTYPE -> IO String
typename l n = c_lua_typename l (fromIntegral (fromEnum n)) >>= peekCString
xmove :: LuaState -> LuaState -> Int -> IO ()
xmove l1 l2 n = c_lua_xmove l1 l2 (fromIntegral n)
yield :: LuaState -> Int -> IO Int
yield l n = liftM fromIntegral (c_lua_yield l (fromIntegral n))
checkstack :: LuaState -> Int -> IO Bool
checkstack l n = liftM (/=0) (c_lua_checkstack l (fromIntegral n))
newstate :: IO LuaState
newstate = c_luaL_newstate
close :: LuaState -> IO ()
close = c_lua_close
concat :: LuaState -> Int -> IO ()
concat l n = c_lua_concat l (fromIntegral n)
call :: LuaState -> Int -> Int -> IO ()
call l a b = c_lua_call l (fromIntegral a) (fromIntegral b)
pcall :: LuaState -> Int -> Int -> Int -> IO Int
pcall l a b c = liftM fromIntegral (c_lua_pcall l (fromIntegral a) (fromIntegral b) (fromIntegral c))
cpcall :: LuaState -> FunPtr LuaCFunction -> Ptr a -> IO Int
cpcall l a c = liftM fromIntegral (c_lua_cpcall l a c)
getfield :: LuaState -> Int -> String -> IO ()
getfield l i n = withCString n $ \n -> c_lua_getfield l (fromIntegral i) n
setfield :: LuaState -> Int -> String -> IO ()
setfield l i n = withCString n $ \n -> c_lua_setfield l (fromIntegral i) n
getglobal :: LuaState -> String -> IO ()
getglobal l n = getfield l globalsindex n
setglobal :: LuaState -> String -> IO ()
setglobal l n = setfield l globalsindex n
openlibs :: LuaState -> IO ()
openlibs = c_luaL_openlibs
foreign import ccall "wrapper" mkStringWriter :: LuaWriter -> IO (FunPtr LuaWriter)
dump :: LuaState -> IO String
dump l = do
r <- newIORef ""
let wr :: LuaWriter
wr _l p s _d = do
k <- peekCStringLen (p,fromIntegral s)
modifyIORef r (++k)
return 0
writer <- mkStringWriter wr
c_lua_dump l writer nullPtr
freeHaskellFunPtr writer
readIORef r
equal :: LuaState -> Int -> Int -> IO Bool
equal l i j = liftM (/=0) (c_lua_equal l (fromIntegral i) (fromIntegral j))
gc :: LuaState -> GCCONTROL -> Int -> IO Int
gc l i j= liftM fromIntegral (c_lua_gc l (fromIntegral (fromEnum i)) (fromIntegral j))
getfenv :: LuaState -> Int -> IO ()
getfenv l n = c_lua_getfenv l (fromIntegral n)
getmetatable :: LuaState -> Int -> IO Bool
getmetatable l n = liftM (/=0) (c_lua_getmetatable l (fromIntegral n))
gettable :: LuaState -> Int -> IO ()
gettable l n = c_lua_gettable l (fromIntegral n)
gettop :: LuaState -> IO Int
gettop l = liftM fromIntegral (c_lua_gettop l)
getupvalue :: LuaState -> Int -> Int -> IO String
getupvalue l funcindex n = c_lua_getupvalue l (fromIntegral funcindex) (fromIntegral n) >>= peekCString
insert :: LuaState -> Int -> IO ()
insert l n = c_lua_insert l (fromIntegral n)
iscfunction :: LuaState -> Int -> IO Bool
iscfunction l n = liftM (/=0) (c_lua_iscfunction l (fromIntegral n))
isnumber :: LuaState -> Int -> IO Bool
isnumber l n = liftM (/=0) (c_lua_isnumber l (fromIntegral n))
isstring :: LuaState -> Int -> IO Bool
isstring l n = liftM (/=0) (c_lua_isstring l (fromIntegral n))
isuserdata :: LuaState -> Int -> IO Bool
isuserdata l n = liftM (/=0) (c_lua_isuserdata l (fromIntegral n))
lessthan :: LuaState -> Int -> Int -> IO Bool
lessthan l i j = liftM (/=0) (c_lua_lessthan l (fromIntegral i) (fromIntegral j))
loadfile :: LuaState -> String -> IO Int
loadfile l f = readFile f >>= \c -> loadstring l c f
foreign import ccall "wrapper" mkStringReader :: LuaReader -> IO (FunPtr LuaReader)
loadstring :: LuaState -> String -> String -> IO Int
loadstring l script cn = do
w <- newIORef nullPtr
let rd :: LuaReader
rd _l _d ps = do
k <- readIORef w
if k==nullPtr
then do
(k,l) <- newCStringLen script
writeIORef w k
F.poke ps (fromIntegral l)
return k
else do
return nullPtr
writer <- mkStringReader rd
res <- withCString cn $ \cn -> c_lua_load l writer nullPtr cn
freeHaskellFunPtr writer
k <- readIORef w
free k
return (fromIntegral res)
newthread :: LuaState -> IO LuaState
newthread l = c_lua_newthread l
newuserdata :: LuaState -> Int -> IO (Ptr ())
newuserdata l s = c_lua_newuserdata l (fromIntegral s)
next :: LuaState -> Int -> IO Bool
next l i = liftM (/=0) (c_lua_next l (fromIntegral i))
pushboolean :: LuaState -> Bool -> IO ()
pushboolean l v = c_lua_pushboolean l (fromIntegral (fromEnum v))
pushinteger :: LuaState -> LuaInteger -> IO ()
pushinteger = c_lua_pushinteger
pushlightuserdata :: LuaState -> Ptr a -> IO ()
pushlightuserdata = c_lua_pushlightuserdata
pushnil :: LuaState -> IO ()
pushnil = c_lua_pushnil
pushnumber :: LuaState -> LuaNumber -> IO ()
pushnumber = c_lua_pushnumber
pushstring :: LuaState -> String -> IO ()
pushstring l s = withCStringLen s $ \(s,z) -> c_lua_pushlstring l s (fromIntegral z)
pushthread :: LuaState -> IO Bool
pushthread l = liftM (/=0) (c_lua_pushthread l)
pushvalue :: LuaState -> Int -> IO ()
pushvalue l n = c_lua_pushvalue l (fromIntegral n)
rawequal :: LuaState -> Int -> Int -> IO Bool
rawequal l n m = liftM (/=0) (c_lua_rawequal l (fromIntegral n) (fromIntegral m))
rawget :: LuaState -> Int -> IO ()
rawget l n = c_lua_rawget l (fromIntegral n)
rawgeti :: LuaState -> Int -> Int -> IO ()
rawgeti l k m = c_lua_rawgeti l (fromIntegral k) (fromIntegral m)
rawset :: LuaState -> Int -> IO ()
rawset l n = c_lua_rawset l (fromIntegral n)
rawseti :: LuaState -> Int -> Int -> IO ()
rawseti l k m = c_lua_rawseti l (fromIntegral k) (fromIntegral m)
remove :: LuaState -> Int -> IO ()
remove l n = c_lua_remove l (fromIntegral n)
replace :: LuaState -> Int -> IO ()
replace l n = c_lua_replace l (fromIntegral n)
resume :: LuaState -> Int -> IO Int
resume l n = liftM fromIntegral (c_lua_resume l (fromIntegral n))
setfenv :: LuaState -> Int -> IO Int
setfenv l n = liftM fromIntegral (c_lua_setfenv l (fromIntegral n))
setmetatable :: LuaState -> Int -> IO ()
setmetatable l n = c_lua_setmetatable l (fromIntegral n)
settable :: LuaState -> Int -> IO ()
settable l index = c_lua_settable l (fromIntegral index)
setupvalue :: LuaState -> Int -> Int -> IO String
setupvalue l funcindex n = c_lua_setupvalue l (fromIntegral funcindex) (fromIntegral n) >>= peekCString
status :: LuaState -> IO Int
status l = liftM fromIntegral (c_lua_status l)
toboolean :: LuaState -> Int -> IO Bool
toboolean l n = liftM (/=0) (c_lua_toboolean l (fromIntegral n))
tocfunction :: LuaState -> Int -> IO (FunPtr LuaCFunction)
tocfunction l n = c_lua_tocfunction l (fromIntegral n)
tointeger :: LuaState -> Int -> IO LuaInteger
tointeger l n = c_lua_tointeger l (fromIntegral n)
tonumber :: LuaState -> Int -> IO CDouble
tonumber l n = c_lua_tonumber l (fromIntegral n)
topointer :: LuaState -> Int -> IO (Ptr ())
topointer l n = c_lua_topointer l (fromIntegral n)
register :: LuaState -> String -> FunPtr LuaCFunction -> IO ()
register l n f = do
pushcclosure l f 0
setglobal l n
newmetatable :: LuaState -> String -> IO Int
newmetatable l s = withCString s $ \s -> liftM fromIntegral (c_luaL_newmetatable l s)
argerror :: LuaState -> Int -> String -> IO CInt
argerror l n msg = withCString msg $ \msg -> do
let doit l = c_luaL_argerror l (fromIntegral n) msg
f <- mkWrapper doit
c_lua_cpcall l f nullPtr
freeHaskellFunPtr f
return (1)
ref :: LuaState -> Int -> IO Int
ref l n = fmap fromIntegral $ c_luaL_ref l (fromIntegral n)
unref :: LuaState -> Int -> Int -> IO ()
unref l t ref = c_luaL_unref l (fromIntegral t) (fromIntegral ref)
class StackValue a where
push :: LuaState -> a -> IO ()
peek :: LuaState -> Int -> IO (Maybe a)
valuetype :: a -> LTYPE
maybepeek :: l -> n -> (l -> n -> IO Bool) -> (l -> n -> IO r) -> IO (Maybe r)
maybepeek l n test peek = do
v <- test l n
if v
then liftM Just (peek l n)
else return Nothing
instance StackValue LuaInteger where
push l x = pushinteger l x
peek l n = maybepeek l n isnumber tointeger
valuetype _ = TNUMBER
instance StackValue LuaNumber where
push l x = pushnumber l x
peek l n = maybepeek l n isnumber tonumber
valuetype _ = TNUMBER
instance StackValue Int where
push l x = pushinteger l (fromIntegral x)
peek l n = maybepeek l n isnumber (\l n -> liftM fromIntegral (tointeger l n))
valuetype _ = TNUMBER
instance StackValue Double where
push l x = pushnumber l (realToFrac x)
peek l n = maybepeek l n isnumber (\l n -> liftM realToFrac (tonumber l n))
valuetype _ = TNUMBER
instance StackValue String where
push l x = pushstring l x
peek l n = maybepeek l n isstring tostring
valuetype _ = TSTRING
instance StackValue Bool where
push l x = pushboolean l x
peek l n = maybepeek l n isboolean toboolean
valuetype _ = TBOOLEAN
instance StackValue (FunPtr LuaCFunction) where
push l x = pushcfunction l x
peek l n = maybepeek l n iscfunction tocfunction
valuetype _ = TFUNCTION
instance StackValue (Ptr a) where
push l x = pushlightuserdata l x
peek l n = maybepeek l n isuserdata touserdata
valuetype _ = TUSERDATA
instance StackValue LuaState where
push l _ = pushthread l >> return ()
peek l n = maybepeek l n isthread tothread
valuetype _ = TTHREAD
instance StackValue () where
push l _ = pushnil l
peek l n = maybepeek l n isnil (\_l _n -> return ())
valuetype _ = TNIL
getglobal2 :: LuaState -> String -> IO ()
getglobal2 l n = do
getglobal l x
mapM_ dotable xs
where (x:xs) = splitdot n
splitdot = filter (/=".") . L.groupBy (\a b -> a/='.' && b/='.')
dotable x = getfield l (1) x >> gettop l >>= \n -> remove l (n1)
typenameindex :: LuaState -> Int -> IO String
typenameindex l n = ltype l n >>= typename l
class LuaImport a where
luaimport' :: Int -> a -> LuaCFunction
luaimportargerror :: Int -> String -> a -> LuaCFunction
instance (StackValue a) => LuaImport (IO a) where
luaimportargerror n msg _x l = argerror l n msg
luaimport' _narg x l = x >>= push l >> return 1
instance (StackValue a,LuaImport b) => LuaImport (a -> b) where
luaimportargerror n msg x l = luaimportargerror n msg (x undefined) l
luaimport' narg x l = do
arg <- peek l narg
case arg of
Just v -> luaimport' (narg+1) (x v) l
Nothing -> do
t <- ltype l narg
exp <- typename l (valuetype (fromJust arg))
got <- typename l t
luaimportargerror narg (exp ++ " expected, got " ++ got) (x undefined) l
foreign import ccall "wrapper" mkWrapper :: LuaCFunction -> IO (FunPtr LuaCFunction)
newcfunction :: LuaImport a => a -> IO (FunPtr LuaCFunction)
newcfunction = mkWrapper . luaimport
luaimport :: LuaImport a => a -> LuaCFunction
luaimport a l = luaimport' 1 a l `catch` (\(e :: IOError) -> push l (show e) >> return (1))
freecfunction :: FunPtr LuaCFunction -> IO ()
freecfunction = freeHaskellFunPtr
class LuaCallProc a where
callproc' :: LuaState -> String -> IO () -> Int -> a
callproc :: (LuaCallProc a) => LuaState -> String -> a
callproc l f = callproc' l f (return ()) 0
class LuaCallFunc a where
callfunc' :: LuaState -> String -> IO () -> Int -> a
callfunc :: (LuaCallFunc a) => LuaState -> String -> a
callfunc l f = callfunc' l f (return ()) 0
instance LuaCallProc (IO t) where
callproc' l f a k = do
getglobal2 l f
a
z <- pcall l k 0 0
if z/=0
then do
Just msg <- peek l (1)
pop l 1
fail msg
else do
return undefined
instance (StackValue t) => LuaCallFunc (IO t) where
callfunc' l f a k = do
getglobal2 l f
a
z <- pcall l k 1 0
if z/=0
then do
Just msg <- peek l (1)
pop l 1
fail msg
else do
r <- peek l (1)
pop l 1
case r of
Just x -> return x
Nothing -> do
exp <- typename l (valuetype (fromJust r))
t <- ltype l (1)
got <- typename l t
fail ("Incorrect result type (" ++ exp ++ " expected, got " ++ got ++ ")")
instance (StackValue t,LuaCallProc b) => LuaCallProc (t -> b) where
callproc' l f a k x = callproc' l f (a >> push l x) (k+1)
instance (StackValue t,LuaCallFunc b) => LuaCallFunc (t -> b) where
callfunc' l f a k x = callfunc' l f (a >> push l x) (k+1)
foreign export ccall hsmethod__gc :: LuaState -> IO CInt
foreign import ccall "&hsmethod__gc" hsmethod__gc_addr :: FunPtr LuaCFunction
foreign export ccall hsmethod__call :: LuaState -> IO CInt
foreign import ccall "&hsmethod__call" hsmethod__call_addr :: FunPtr LuaCFunction
hsmethod__gc :: LuaState -> IO CInt
hsmethod__gc l = do
Just ptr <- peek l (1)
stableptr <- F.peek (castPtr ptr)
freeStablePtr stableptr
return 0
hsmethod__call :: LuaState -> IO CInt
hsmethod__call l = do
Just ptr <- peek l 1
remove l 1
stableptr <- F.peek (castPtr ptr)
f <- deRefStablePtr stableptr
f l
pushhsfunction :: LuaImport a => LuaState -> a -> IO ()
pushhsfunction l f = do
stableptr <- newStablePtr (luaimport f)
p <- newuserdata l (F.sizeOf stableptr);
F.poke (castPtr p) stableptr
v <- newmetatable l "HaskellImportedFunction"
when (v/=0) $ do
push l hsmethod__gc_addr
setfield l (2) "__gc"
push l c_lua_neutralize_longjmp_addr
setfield l (2) "__call"
setmetatable l (2)
return ()
pushrawhsfunction :: LuaState -> (LuaState -> IO CInt) -> IO ()
pushrawhsfunction l f = do
stableptr <- newStablePtr f
p <- newuserdata l (F.sizeOf stableptr);
F.poke (castPtr p) stableptr
v <- newmetatable l "HaskellImportedFunction"
when (v/=0) $ do
push l hsmethod__gc_addr
setfield l (2) "__gc"
push l c_lua_neutralize_longjmp_addr
setfield l (2) "__call"
setmetatable l (2)
return ()
registerhsfunction :: LuaImport a => LuaState -> String -> a -> IO ()
registerhsfunction l n f = pushhsfunction l f >> setglobal l n
registerrawhsfunction :: LuaState -> String -> (LuaState -> IO CInt) -> IO ()
registerrawhsfunction l n f = pushrawhsfunction l f >> setglobal l n