{-# LINE 1 "src/Foreign/Lua/FunctionCalling.hsc" #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Foreign.Lua.FunctionCalling
Copyright   : © 2007–2012 Gracjan Polak,
                2012–2016 Ömer Sinan Ağacan,
                2017-2019 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : FlexibleInstances, ForeignFunctionInterface, ScopedTypeVariables

Call haskell functions from Lua, and vice versa.
-}
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 of raw Haskell functions that can be made into 'CFunction's.
type PreCFunction = Lua.State -> IO NumResults

-- | Haskell function that can be called from Lua.
type HaskellFunction = Lua NumResults

-- | Operations and functions that can be pushed to the Lua stack. This is a
-- helper function not intended to be used directly. Use the
-- @'toHaskellFunction'@ wrapper instead.
class ToHaskellFunction a where
  -- | Helper function, called by @'toHaskellFunction'@
  toHsFun :: StackIndex -> a -> Lua NumResults

instance {-# OVERLAPPING #-} ToHaskellFunction HaskellFunction where
  toHsFun :: StackIndex -> HaskellFunction -> HaskellFunction
toHsFun StackIndex
_ = HaskellFunction -> HaskellFunction
forall a. a -> a
id

instance Pushable a => ToHaskellFunction (Lua a) where
  toHsFun :: StackIndex -> Lua a -> HaskellFunction
toHsFun StackIndex
_narg Lua a
x = NumResults
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 StackIndex
narg 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
+ StackIndex
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 = String
"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
<> String
": "

-- | Convert a Haskell function to Lua function. Any Haskell function
-- can be converted provided that:
--
--   * all arguments are instances of @'Peekable'@
--   * return type is @Lua a@, where @a@ is an instance of
--     @'Pushable'@
--
-- Any @'Lua.Exception'@ will be converted to a string and returned
-- as Lua error.
--
-- /Important/: this does __not__ catch exceptions other than
-- @'Lua.Exception'@; exception handling must be done by the converted
-- Haskell function. Failure to do so will cause the program to crash.
--
-- E.g., the following code could be used to handle an Exception of type
-- FooException, if that type is an instance of @'MonadCatch'@ and
-- @'Pushable'@:
--
-- > toHaskellFunction (myFun `catchM` (\e -> raiseError (e :: FooException)))
--
toHaskellFunction :: ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction :: a -> HaskellFunction
toHaskellFunction a
a = StackIndex -> a -> HaskellFunction
forall a. ToHaskellFunction a => StackIndex -> a -> HaskellFunction
toHsFun StackIndex
1 a
a HaskellFunction
-> (Exception -> HaskellFunction) -> HaskellFunction
forall a. Lua a -> (Exception -> Lua a) -> Lua a
`catchException` \(Lua.Exception String
msg) ->
  String -> HaskellFunction
forall a. Pushable a => a -> HaskellFunction
raiseError (String
"Error during function call: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)

-- | Create new foreign Lua function. Function created can be called
-- by Lua engine. Remeber to free the pointer with @freecfunction@.
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

-- | Turn a @'PreCFunction'@ into an actual @'CFunction'@.
foreign import ccall "wrapper"
  mkWrapper :: PreCFunction -> IO CFunction

-- | Free function pointer created with @newcfunction@.
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

-- | Helper class used to make lua functions useable from haskell
class LuaCallFunc a where
  callFunc' :: String -> Lua () -> NumArgs -> a

instance Peekable a => LuaCallFunc (Lua a) where
  callFunc' :: String -> Lua () -> NumArgs -> Lua a
callFunc' String
fnName Lua ()
pushArgs NumArgs
nargs = do
    String -> Lua ()
getglobal' String
fnName
    Lua ()
pushArgs
    NumArgs -> NumResults -> Lua ()
call NumArgs
nargs NumResults
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' String
fnName Lua ()
pushArgs NumArgs
nargs 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
+ NumArgs
1)

-- | Call a Lua function. Use as:
--
-- > v <- callfunc "proc" "abc" (1::Int) (5.0::Double)
callFunc :: (LuaCallFunc a) => String -> a
callFunc :: String -> a
callFunc 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 ()) NumArgs
0

-- | Imports a Haskell function and registers it at global name.
registerHaskellFunction :: ToHaskellFunction a => String -> a -> Lua ()
registerHaskellFunction :: String -> a -> Lua ()
registerHaskellFunction String
n a
f = do
  a -> Lua ()
forall a. ToHaskellFunction a => a -> Lua ()
pushHaskellFunction a
f
  String -> Lua ()
setglobal String
n

-- | Pushes Haskell function as a callable userdata.
-- All values created will be garbage collected. Use as:
--
-- > pushHaskellFunction myfun
-- > setglobal "myfun"
--
-- Error conditions should be indicated by raising a Lua @'Lua.Exception'@
-- or by returning the result of @'Lua.error'@.
pushHaskellFunction :: ToHaskellFunction a => a -> Lua ()
pushHaskellFunction :: a -> Lua ()
pushHaskellFunction 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
  -- Convert userdata object into a CFuntion.
  CFunction -> NumArgs -> Lua ()
pushcclosure CFunction
hslua_call_hs_ptr NumArgs
1

-- | Convert callable userdata at top of stack into a CFunction, translating
-- errors to Lua errors.  Use with @'pushcclosure'@.
foreign import ccall "error-conversion.h &hslua_call_hs"
  hslua_call_hs_ptr :: CFunction

hsLuaFunctionName :: String
hsLuaFunctionName :: String
hsLuaFunctionName = String
"HsLuaFunction"

-- | Converts a pre C function to a Lua function and pushes it to the stack.
--
-- Pre C functions collect parameters from the stack and return
-- a `CInt` that represents number of return values left in the stack.
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction PreCFunction
f =
  let pushMetatable :: Lua ()
pushMetatable = String -> Lua () -> Lua ()
ensureUserdataMetatable String
hsLuaFunctionName (Lua () -> Lua ()) -> Lua () -> Lua ()
forall a b. (a -> b) -> a -> b
$ do
        -- ensure the userdata will be callable
        CFunction -> Lua ()
pushcfunction CFunction
hslua_call_wrapped_hs_fun_ptr
        StackIndex -> String -> Lua ()
setfield (-StackIndex
2) String
"__call"
  in Lua () -> PreCFunction -> Lua ()
forall a. Lua () -> a -> Lua ()
pushAnyWithMetatable Lua ()
pushMetatable PreCFunction
f

-- | Call the Haskell function stored in the userdata. This function is exported
-- as a C function and then re-imported in order to get a C function pointer.
hslua_call_wrapped_hs_fun :: Lua.State -> IO NumResults
hslua_call_wrapped_hs_fun :: PreCFunction
hslua_call_wrapped_hs_fun 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
    Maybe PreCFunction
Nothing -> State -> HaskellFunction -> IO NumResults
forall a. State -> Lua a -> IO a
runWith State
l (ByteString -> HaskellFunction
forall a. Pushable a => a -> HaskellFunction
raiseError (ByteString
"Could not call function" :: ByteString))
    Just 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