{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-|
Module      : HsLua.Class.Exposable
Copyright   : © 2007–2012 Gracjan Polak,
                2012–2016 Ömer Sinan Ağacan,
                2017-2022 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>

Call Haskell functions from Lua.
-}
module HsLua.Class.Exposable
  ( Exposable (..)
  , toHaskellFunction
  , pushAsHaskellFunction
  , registerHaskellFunction
  ) where

import Data.String (fromString)
import HsLua.Core as Lua
import HsLua.Marshalling (Peek, forcePeek, liftLua, retrieving, withContext)
import HsLua.Class.Peekable (Peekable (safepeek))
import HsLua.Class.Pushable (Pushable (push))

-- | 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 LuaError e => Exposable e a where
  -- | Helper function, called by @'toHaskellFunction'@. Should do a
  -- partial application of the argument at the given index to the
  -- underlying function. Recurses if necessary, causing further partial
  -- applications until the operation is a easily exposable to Lua.
  partialApply :: StackIndex -> a -> Peek e NumResults

instance {-# OVERLAPPING #-} LuaError e =>
         Exposable e (HaskellFunction e) where
  partialApply :: StackIndex -> HaskellFunction e -> Peek e NumResults
partialApply StackIndex
_ = HaskellFunction e -> Peek e NumResults
forall e a. LuaE e a -> Peek e a
liftLua

instance (LuaError e, Pushable a) => Exposable e (LuaE e a) where
  partialApply :: StackIndex -> LuaE e a -> Peek e NumResults
partialApply StackIndex
_narg LuaE e a
x = NumResults
1 NumResults -> Peek e () -> Peek e NumResults
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e a
x LuaE e a -> (a -> LuaE e ()) -> LuaE e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> LuaE e ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push)

instance (LuaError e, Pushable a) => Exposable e (Peek e a) where
  partialApply :: StackIndex -> Peek e a -> Peek e NumResults
partialApply StackIndex
_narg Peek e a
x = NumResults
1 NumResults -> Peek e () -> Peek e NumResults
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Peek e a
x Peek e a -> (a -> Peek e ()) -> Peek e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> (a -> LuaE e ()) -> a -> Peek e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LuaE e ()
forall a e. (Pushable a, LuaError e) => a -> LuaE e ()
push)

instance (Peekable a, Exposable e b) => Exposable e (a -> b) where
  partialApply :: StackIndex -> (a -> b) -> Peek e NumResults
partialApply StackIndex
narg a -> b
f = Peek e a
getArg Peek e a -> (a -> Peek e NumResults) -> Peek e NumResults
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StackIndex -> b -> Peek e NumResults
forall e a. Exposable e a => StackIndex -> a -> Peek e NumResults
partialApply (StackIndex
narg StackIndex -> StackIndex -> StackIndex
forall a. Num a => a -> a -> a
+ StackIndex
1) (b -> Peek e NumResults) -> (a -> b) -> a -> Peek e NumResults
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
    where
      getArg :: Peek e a
getArg = Name -> Peek e a -> Peek e a
forall e a. Name -> Peek e a -> Peek e a
retrieving (String -> Name
forall a. IsString a => String -> a
fromString String
errorPrefix) (Peeker e a
forall a e. (Peekable a, LuaError e) => Peeker e a
safepeek StackIndex
narg)
      errorPrefix :: String
errorPrefix = String
"argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show (StackIndex -> CInt
fromStackIndex StackIndex
narg)

-- | Convert a Haskell function to a function type directly exposable to
-- Lua. Any Haskell function can be converted provided that:
--
--   * all arguments are instances of @'Peekable'@
--   * return type is @LuaE e a@, where @a@ is an instance of
--     @'Pushable'@
--
-- Any exception of type @e@ will be caught.
--
-- /Important/: this does __not__ catch exceptions other than @e@;
-- exception handling must be done by the 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 :: forall e a. Exposable e a => a -> HaskellFunction e
toHaskellFunction :: a -> HaskellFunction e
toHaskellFunction a
a = Peek e NumResults -> HaskellFunction e
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek e NumResults -> HaskellFunction e)
-> Peek e NumResults -> HaskellFunction e
forall a b. (a -> b) -> a -> b
$ do
  Name -> Peek e NumResults -> Peek e NumResults
forall e a. Name -> Peek e a -> Peek e a
withContext Name
"executing function call" (Peek e NumResults -> Peek e NumResults)
-> Peek e NumResults -> Peek e NumResults
forall a b. (a -> b) -> a -> b
$ StackIndex -> a -> Peek e NumResults
forall e a. Exposable e a => StackIndex -> a -> Peek e NumResults
partialApply StackIndex
1 a
a

-- | Pushes the given value as a function to the Lua stack.
--
-- See 'toHaskellFunction' for details.
pushAsHaskellFunction :: forall e a. Exposable e a => a -> LuaE e ()
pushAsHaskellFunction :: a -> LuaE e ()
pushAsHaskellFunction = HaskellFunction e -> LuaE e ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction (HaskellFunction e -> LuaE e ())
-> (a -> HaskellFunction e) -> a -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HaskellFunction e
forall e a. Exposable e a => a -> HaskellFunction e
toHaskellFunction

-- | Imports a Haskell function and registers it at global name.
registerHaskellFunction :: Exposable e a
                        => Name -> a -> LuaE e ()
registerHaskellFunction :: Name -> a -> LuaE e ()
registerHaskellFunction Name
n a
f = do
  a -> LuaE e ()
forall e a. Exposable e a => a -> LuaE e ()
pushAsHaskellFunction a
f
  Name -> LuaE e ()
forall e. LuaError e => Name -> LuaE e ()
setglobal Name
n