{-# LANGUAGE CPP #-}
{-|
Module      : Lua.Userdata
Copyright   : © 2017-2022 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : ForeignFunctionInterface

Bindings to HsLua-specific functions used to push Haskell values
as userdata.
-}
module Lua.Userdata
  ( hslua_fromuserdata
  , hslua_newhsuserdatauv
  , hslua_newudmetatable
  , hslua_putuserdata
  ) where

import Foreign.C (CInt (CInt), CString)
import Lua.Auxiliary (luaL_testudata)
import Lua.Primary (lua_newuserdatauv)
import Lua.Types
  ( LuaBool (..)
  , StackIndex (..)
  , State (..)
  )
import Foreign.Ptr (castPtr, nullPtr)
import Foreign.StablePtr (newStablePtr, deRefStablePtr, freeStablePtr)
import Foreign.Storable (peek, poke, sizeOf)

#ifdef ALLOW_UNSAFE_GC
#define SAFTY unsafe
#else
#define SAFTY safe
#endif

-- | Creates and registers a new metatable for a userdata-wrapped
-- Haskell value; checks whether a metatable of that name has been
-- registered yet and uses the registered table if possible.
foreign import ccall SAFTY "hsludata.h hslua_newudmetatable"
  hslua_newudmetatable :: State       -- ^ Lua state
                       -> CString     -- ^ Userdata name (__name)
                       -> IO LuaBool  -- ^ True iff new metatable
                                      --   was created.

-- | Creates a new userdata wrapping the given Haskell object, with
-- @nuvalue@ associated Lua values (uservalues).
hslua_newhsuserdatauv :: State
                      -> a      -- ^ value to be wrapped
                      -> CInt   -- ^ nuvalue
                      -> IO ()
hslua_newhsuserdatauv :: State -> a -> CInt -> IO ()
hslua_newhsuserdatauv State
l a
x CInt
nuvalue = do
  StablePtr a
xPtr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
x
  Ptr ()
udPtr <- State -> CSize -> CInt -> IO (Ptr ())
lua_newuserdatauv State
l (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ StablePtr a -> Int
forall a. Storable a => a -> Int
sizeOf StablePtr a
xPtr) CInt
nuvalue
  Ptr (StablePtr a) -> StablePtr a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr () -> Ptr (StablePtr a)
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) StablePtr a
xPtr
{-# INLINABLE hslua_newhsuserdatauv #-}

-- | Retrieves a Haskell object from userdata at the given index.
-- The userdata /must/ have the given name.
hslua_fromuserdata :: State
                   -> StackIndex  -- ^ userdata index
                   -> CString     -- ^ name
                   -> IO (Maybe a)
hslua_fromuserdata :: State -> StackIndex -> CString -> IO (Maybe a)
hslua_fromuserdata State
l StackIndex
idx CString
name = do
  Ptr ()
udPtr <- State -> StackIndex -> CString -> IO (Ptr ())
luaL_testudata State
l StackIndex
idx CString
name
  if Ptr ()
udPtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
    then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr (StablePtr a) -> IO (StablePtr a)
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr (StablePtr a)
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) IO (StablePtr a) -> (StablePtr a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StablePtr a -> IO a
forall a. StablePtr a -> IO a
deRefStablePtr)
{-# INLINABLE hslua_fromuserdata #-}

-- | Replaces the Haskell value contained in the userdata value at
-- @index@. Checks that the userdata is of type @name@ and returns
-- 'True' on success, or 'False' otherwise.
hslua_putuserdata :: State
                  -> StackIndex  -- ^ index
                  -> CString     -- ^ name
                  -> a           -- ^ new Haskell value
                  -> IO Bool
hslua_putuserdata :: State -> StackIndex -> CString -> a -> IO Bool
hslua_putuserdata State
l StackIndex
idx CString
name a
x = do
  StablePtr a
xPtr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
x
  Ptr ()
udPtr <- State -> StackIndex -> CString -> IO (Ptr ())
luaL_testudata State
l StackIndex
idx CString
name
  if Ptr ()
udPtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
    then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      Ptr (StablePtr Any) -> IO (StablePtr Any)
forall a. Storable a => Ptr a -> IO a
peek (Ptr () -> Ptr (StablePtr Any)
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) IO (StablePtr Any) -> (StablePtr Any -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StablePtr Any -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr
      Ptr (StablePtr a) -> StablePtr a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr () -> Ptr (StablePtr a)
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
udPtr) StablePtr a
xPtr
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
{-# INLINABLE hslua_putuserdata #-}