{-# 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-2020 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
  , pushPreCFunction
  , registerHaskellFunction
  ) where

import Foreign.C (CInt (..))
import Foreign.Lua.Core as Lua
import Foreign.Lua.Core.Types (liftLua)
import Foreign.Lua.Raw.Call (hslua_pushhsfunction)
import Foreign.Lua.Types
import Foreign.Lua.Util (getglobal', popValue)
import Foreign.Ptr (freeHaskellFunPtr)

-- | Type of raw Haskell functions that can be made into
-- 'CFunction's.
type PreCFunction = 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
-- 'Control.Monad.Catch.MonadCatch' and 'Pushable':
--
-- > toHaskellFunction (myFun `catchM` (\e -> raiseError (e :: FooException)))
--
toHaskellFunction :: ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction :: a -> HaskellFunction
toHaskellFunction a
a = do
  ErrorConversion
errConv <- Lua ErrorConversion
Lua.errorConversion
  let ctx :: String
ctx = String
"Error during function call: "
  ErrorConversion -> HaskellFunction -> HaskellFunction
Lua.exceptionToError ErrorConversion
errConv (HaskellFunction -> HaskellFunction)
-> (HaskellFunction -> HaskellFunction)
-> HaskellFunction
-> HaskellFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorConversion -> String -> HaskellFunction -> HaskellFunction
ErrorConversion -> forall a. String -> Lua a -> Lua a
Lua.addContextToException ErrorConversion
errConv String
ctx (HaskellFunction -> HaskellFunction)
-> HaskellFunction -> HaskellFunction
forall a b. (a -> b) -> a -> b
$
    StackIndex -> a -> HaskellFunction
forall a. ToHaskellFunction a => StackIndex -> a -> HaskellFunction
toHsFun StackIndex
1 a
a

-- | Create new foreign Lua function. Function created can be called by
-- the Lua engine. Remeber to free the pointer with @freecfunction@.
newCFunction :: ToHaskellFunction a => a -> Lua CFunction
newCFunction :: a -> Lua CFunction
newCFunction a
f = do
  ErrorConversion
e2e <- Lua ErrorConversion
Lua.errorConversion
  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 (ErrorConversion -> State -> HaskellFunction -> IO NumResults
forall a. ErrorConversion -> State -> Lua a -> IO a
Lua.runWithConverter ErrorConversion
e2e) (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 (a -> Lua CFunction) -> a -> Lua CFunction
forall a b. (a -> b) -> a -> b
$ a
f

-- | Turn a @'PreCFunction'@ into an actual @'CFunction'@.
foreign import ccall unsafe "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
  ErrorConversion
errConv <- Lua ErrorConversion
Lua.errorConversion
  PreCFunction
preCFn <- PreCFunction -> Lua PreCFunction
forall (m :: * -> *) a. Monad m => a -> m a
return (PreCFunction -> Lua PreCFunction)
-> (HaskellFunction -> PreCFunction)
-> HaskellFunction
-> Lua PreCFunction
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 (ErrorConversion -> State -> HaskellFunction -> IO NumResults
forall a. ErrorConversion -> State -> Lua a -> IO a
runWithConverter ErrorConversion
errConv) (HaskellFunction -> Lua PreCFunction)
-> HaskellFunction -> Lua PreCFunction
forall a b. (a -> b) -> a -> b
$ a -> HaskellFunction
forall a. ToHaskellFunction a => a -> HaskellFunction
toHaskellFunction a
hsFn
  PreCFunction -> Lua ()
pushPreCFunction PreCFunction
preCFn

-- | 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 on the stack.
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction :: PreCFunction -> Lua ()
pushPreCFunction PreCFunction
preCFn = (State -> IO ()) -> Lua ()
forall a. (State -> IO a) -> Lua a
liftLua ((State -> IO ()) -> Lua ()) -> (State -> IO ()) -> Lua ()
forall a b. (a -> b) -> a -> b
$ \State
l ->
  State -> PreCFunction -> IO ()
hslua_pushhsfunction State
l PreCFunction
preCFn