{-# LINE 1 "src/Foreign/Lua/FunctionCalling.hsc" #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Foreign.Lua.FunctionCalling
( Peekable (..)
, LuaCallFunc (..)
, ToHaskellFunction (..)
, HaskellFunction
, Pushable (..)
, PreCFunction
, toHaskellFunction
, callFunc
, freeCFunction
, newCFunction
, pushHaskellFunction
, registerHaskellFunction
) where
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Foreign.C (CInt (..))
import Foreign.Lua.Core as Lua
import Foreign.Lua.Types
import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable
, toAnyWithName )
import Foreign.Lua.Util (getglobal', popValue, raiseError)
import Foreign.Ptr (freeHaskellFunPtr)
type PreCFunction = Lua.State -> IO NumResults
type HaskellFunction = Lua NumResults
class ToHaskellFunction a where
toHsFun :: StackIndex -> a -> Lua NumResults
instance {-# OVERLAPPING #-} ToHaskellFunction HaskellFunction where
toHsFun :: StackIndex -> HaskellFunction -> HaskellFunction
toHsFun _ = HaskellFunction -> HaskellFunction
forall a. a -> a
id
instance Pushable a => ToHaskellFunction (Lua a) where
toHsFun :: StackIndex -> Lua a -> HaskellFunction
toHsFun _narg :: StackIndex
_narg x :: Lua a
x = 1 NumResults -> Lua () -> HaskellFunction
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Lua a
x Lua a -> (a -> Lua ()) -> Lua ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Lua ()
forall a. Pushable a => a -> Lua ()
push)
instance (Peekable a, ToHaskellFunction b) =>
ToHaskellFunction (a -> b) where
toHsFun :: StackIndex -> (a -> b) -> HaskellFunction
toHsFun narg :: StackIndex
narg f :: a -> b
f = Lua a
getArg Lua a -> (a -> HaskellFunction) -> HaskellFunction
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StackIndex -> b -> HaskellFunction
forall a. ToHaskellFunction a => StackIndex -> a -> HaskellFunction
toHsFun (StackIndex
narg StackIndex -> StackIndex -> StackIndex
forall a. Num a => a -> a -> a
+ 1) (b -> HaskellFunction) -> (a -> b) -> a -> HaskellFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
where
getArg :: Lua a
getArg = (String -> String) -> Lua a -> Lua a
forall a. (String -> String) -> Lua a -> Lua a
Lua.withExceptionMessage (String
errorPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (StackIndex -> Lua a
forall a. Peekable a => StackIndex -> Lua a
peek StackIndex
narg)
errorPrefix :: String
errorPrefix = "could not read argument " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
CInt -> String
forall a. Show a => a -> String
show (StackIndex -> CInt
fromStackIndex StackIndex
narg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ": "
toHaskellFunction :: ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction :: a -> HaskellFunction
toHaskellFunction a :: a
a = StackIndex -> a -> HaskellFunction
forall a. ToHaskellFunction a => StackIndex -> a -> HaskellFunction
toHsFun 1 a
a HaskellFunction
-> (Exception -> HaskellFunction) -> HaskellFunction
forall a. Lua a -> (Exception -> Lua a) -> Lua a
`catchException` \(Lua.Exception msg :: String
msg) ->
String -> HaskellFunction
forall a. Pushable a => a -> HaskellFunction
raiseError ("Error during function call: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
newCFunction :: ToHaskellFunction a => a -> Lua CFunction
newCFunction :: a -> Lua CFunction
newCFunction = IO CFunction -> Lua CFunction
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CFunction -> Lua CFunction)
-> (a -> IO CFunction) -> a -> Lua CFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreCFunction -> IO CFunction
mkWrapper (PreCFunction -> IO CFunction)
-> (a -> PreCFunction) -> a -> IO CFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> HaskellFunction -> IO NumResults)
-> HaskellFunction -> PreCFunction
forall a b c. (a -> b -> c) -> b -> a -> c
flip State -> HaskellFunction -> IO NumResults
forall a. State -> Lua a -> IO a
runWith (HaskellFunction -> PreCFunction)
-> (a -> HaskellFunction) -> a -> PreCFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HaskellFunction
forall a. ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction
foreign import ccall "wrapper"
mkWrapper :: PreCFunction -> IO CFunction
freeCFunction :: CFunction -> Lua ()
freeCFunction :: CFunction -> Lua ()
freeCFunction = IO () -> Lua ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Lua ()) -> (CFunction -> IO ()) -> CFunction -> Lua ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFunction -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr
class LuaCallFunc a where
callFunc' :: String -> Lua () -> NumArgs -> a
instance Peekable a => LuaCallFunc (Lua a) where
callFunc' :: String -> Lua () -> NumArgs -> Lua a
callFunc' fnName :: String
fnName pushArgs :: Lua ()
pushArgs nargs :: NumArgs
nargs = do
String -> Lua ()
getglobal' String
fnName
Lua ()
pushArgs
NumArgs -> NumResults -> Lua ()
call NumArgs
nargs 1
Lua a
forall a. Peekable a => Lua a
popValue
instance (Pushable a, LuaCallFunc b) => LuaCallFunc (a -> b) where
callFunc' :: String -> Lua () -> NumArgs -> a -> b
callFunc' fnName :: String
fnName pushArgs :: Lua ()
pushArgs nargs :: NumArgs
nargs x :: a
x =
String -> Lua () -> NumArgs -> b
forall a. LuaCallFunc a => String -> Lua () -> NumArgs -> a
callFunc' String
fnName (Lua ()
pushArgs Lua () -> Lua () -> Lua ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> Lua ()
forall a. Pushable a => a -> Lua ()
push a
x) (NumArgs
nargs NumArgs -> NumArgs -> NumArgs
forall a. Num a => a -> a -> a
+ 1)
callFunc :: (LuaCallFunc a) => String -> a
callFunc :: String -> a
callFunc f :: String
f = String -> Lua () -> NumArgs -> a
forall a. LuaCallFunc a => String -> Lua () -> NumArgs -> a
callFunc' String
f (() -> Lua ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) 0
registerHaskellFunction :: ToHaskellFunction a => String -> a -> Lua ()
registerHaskellFunction :: String -> a -> Lua ()
registerHaskellFunction n :: String
n f :: a
f = do
a -> Lua ()
forall a. ToHaskellFunction a => a -> Lua ()
pushHaskellFunction a
f
String -> Lua ()
setglobal String
n
pushHaskellFunction :: ToHaskellFunction a => a -> Lua ()
pushHaskellFunction :: a -> Lua ()
pushHaskellFunction hsFn :: a
hsFn = do
PreCFunction -> Lua ()
pushPreCFunction (PreCFunction -> Lua ())
-> (HaskellFunction -> PreCFunction) -> HaskellFunction -> Lua ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> HaskellFunction -> IO NumResults)
-> HaskellFunction -> PreCFunction
forall a b c. (a -> b -> c) -> b -> a -> c
flip State -> HaskellFunction -> IO NumResults
forall a. State -> Lua a -> IO a
runWith (HaskellFunction -> Lua ()) -> HaskellFunction -> Lua ()
forall a b. (a -> b) -> a -> b
$ a -> HaskellFunction
forall a. ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction a
hsFn
CFunction -> NumArgs -> Lua ()
pushcclosure CFunction
hslua_call_hs_ptr 1
foreign import ccall "error-conversion.h &hslua_call_hs"
hslua_call_hs_ptr :: CFunction
hsLuaFunctionName :: String
hsLuaFunctionName :: String
hsLuaFunctionName = "HsLuaFunction"
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction f :: PreCFunction
f =
let pushMetatable :: Lua ()
pushMetatable = String -> Lua () -> Lua ()
ensureUserdataMetatable String
hsLuaFunctionName (Lua () -> Lua ()) -> Lua () -> Lua ()
forall a b. (a -> b) -> a -> b
$ do
CFunction -> Lua ()
pushcfunction CFunction
hslua_call_wrapped_hs_fun_ptr
StackIndex -> String -> Lua ()
setfield (-2) "__call"
in Lua () -> PreCFunction -> Lua ()
forall a. Lua () -> a -> Lua ()
pushAnyWithMetatable Lua ()
pushMetatable PreCFunction
f
hslua_call_wrapped_hs_fun :: Lua.State -> IO NumResults
hslua_call_wrapped_hs_fun :: PreCFunction
hslua_call_wrapped_hs_fun l :: State
l = do
Maybe PreCFunction
mbFn <- State -> Lua (Maybe PreCFunction) -> IO (Maybe PreCFunction)
forall a. State -> Lua a -> IO a
runWith State
l (StackIndex -> String -> Lua (Maybe PreCFunction)
forall a. StackIndex -> String -> Lua (Maybe a)
toAnyWithName StackIndex
stackBottom String
hsLuaFunctionName
Lua (Maybe PreCFunction) -> Lua () -> Lua (Maybe PreCFunction)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StackIndex -> Lua ()
remove StackIndex
stackBottom)
case Maybe PreCFunction
mbFn of
Nothing -> State -> HaskellFunction -> IO NumResults
forall a. State -> Lua a -> IO a
runWith State
l (ByteString -> HaskellFunction
forall a. Pushable a => a -> HaskellFunction
raiseError ("Could not call function" :: ByteString))
Just fn :: PreCFunction
fn -> PreCFunction
fn State
l
foreign export ccall hslua_call_wrapped_hs_fun :: PreCFunction
foreign import ccall "&hslua_call_wrapped_hs_fun"
hslua_call_wrapped_hs_fun_ptr :: CFunction