{-# LANGUAGE OverloadedStrings   #-}
{-|
Module      : Foreign.Lua.Userdata
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 : non-portable (depends on GHC)

Convenience functions to convert Haskell values into Lua userdata.

The main purpose of this module is to allow fast and simple creation of
instances for @'Peekable'@ and @'Pushable'@. E.g., given a data type Person

> data Person = Person { name :: String, age :: Int }
>    deriving (Eq, Show, Typeable, Data)

we can simply do

> instance Lua.Peekable Person where
>     safePeek = safePeekAny
>
> instance Lua.Pushable Person where
>     push = pushAny

The other functions can be used to exert more control over the userdata wrapping
and unwrapping process.
-}
module Foreign.Lua.Userdata
  ( pushAny
  , pushAnyWithMetatable
  , toAny
  , toAnyWithName
  , peekAny
  , ensureUserdataMetatable
  , metatableName
  ) where

-- import Control.Applicative (empty)
import Control.Monad (when)
import Data.Data (Data, dataTypeName, dataTypeOf)
import Foreign.Lua.Core (Lua)
import Foreign.Lua.Types.Peekable (reportValueOnFailure)

import qualified Foreign.Lua.Core as Lua
import qualified Foreign.C as C
import qualified Foreign.Ptr as Ptr
import qualified Foreign.StablePtr as StablePtr
import qualified Foreign.Storable as Storable


-- | Push data by wrapping it into a userdata object.
pushAny :: Data a
        => a
        -> Lua ()
pushAny :: a -> Lua ()
pushAny a
x =
  let name :: String
name = a -> String
forall a. Data a => a -> String
metatableName a
x
      pushMetatable :: Lua ()
pushMetatable = String -> Lua () -> Lua ()
ensureUserdataMetatable String
name (() -> Lua ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  in Lua () -> a -> Lua ()
forall a. Lua () -> a -> Lua ()
pushAnyWithMetatable Lua ()
pushMetatable a
x

-- | Push data by wrapping it into a userdata object, using the object at the
-- top of the stack after performing the given operation as metatable.
pushAnyWithMetatable :: Lua ()       -- ^ operation to push the metatable
                     -> a            -- ^ object to push to Lua.
                     -> Lua ()
pushAnyWithMetatable :: Lua () -> a -> Lua ()
pushAnyWithMetatable Lua ()
mtOp a
x = do
  StablePtr a
xPtr <- IO (StablePtr a) -> Lua (StablePtr a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
StablePtr.newStablePtr a
x)
  Ptr ()
udPtr <- Int -> Lua (Ptr ())
Lua.newuserdata (StablePtr a -> Int
forall a. Storable a => a -> Int
Storable.sizeOf StablePtr a
xPtr)
  IO () -> Lua ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO () -> Lua ()) -> IO () -> Lua ()
forall a b. (a -> b) -> a -> b
$ Ptr (StablePtr a) -> StablePtr a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Storable.poke (Ptr () -> Ptr (StablePtr a)
forall a b. Ptr a -> Ptr b
Ptr.castPtr Ptr ()
udPtr) StablePtr a
xPtr
  Lua ()
mtOp
  StackIndex -> Lua ()
Lua.setmetatable (CInt -> StackIndex
Lua.nthFromTop CInt
2)
  () -> Lua ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Push the metatable used to define the behavior of the given value in Lua.
-- The table will be created if it doesn't exist yet.
ensureUserdataMetatable :: String     -- ^ name of the registered
                                      -- metatable which should be used.
                        -> Lua ()     -- ^ set additional properties; this
                                      -- operation will be called with the newly
                                      -- created metadata table at the top of
                                      -- the stack.
                        -> Lua ()
ensureUserdataMetatable :: String -> Lua () -> Lua ()
ensureUserdataMetatable String
name Lua ()
modMt = do
  Bool
mtCreated <- String -> Lua Bool
Lua.newmetatable String
name
  Bool -> Lua () -> Lua ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mtCreated (Lua () -> Lua ()) -> Lua () -> Lua ()
forall a b. (a -> b) -> a -> b
$ do
    -- Prevent accessing or changing the metatable with
    -- getmetatable/setmetatable.
    Bool -> Lua ()
Lua.pushboolean Bool
True
    StackIndex -> String -> Lua ()
Lua.setfield (CInt -> StackIndex
Lua.nthFromTop CInt
2) String
"__metatable"
    -- Mark objects for finalization when collecting garbage.
    CFunction -> Lua ()
Lua.pushcfunction CFunction
hslua_userdata_gc_ptr
    StackIndex -> String -> Lua ()
Lua.setfield (CInt -> StackIndex
Lua.nthFromTop CInt
2) String
"__gc"
    -- Execute additional modifications on metatable
    Lua ()
modMt

-- | Retrieve data which has been pushed with @'pushAny'@.
toAny :: Data a => Lua.StackIndex -> Lua (Maybe a)
toAny :: StackIndex -> Lua (Maybe a)
toAny StackIndex
idx = a -> Lua (Maybe a)
forall a. Data a => a -> Lua (Maybe a)
toAny' a
forall a. HasCallStack => a
undefined
 where
  toAny' :: Data a => a -> Lua (Maybe a)
  toAny' :: a -> Lua (Maybe a)
toAny' a
x = StackIndex -> String -> Lua (Maybe a)
forall a. StackIndex -> String -> Lua (Maybe a)
toAnyWithName StackIndex
idx (a -> String
forall a. Data a => a -> String
metatableName a
x)

-- | Retrieve data which has been pushed with @'pushAnyWithMetatable'@, where
-- *name* must is the value of the @__name@ field of the metatable.
toAnyWithName :: Lua.StackIndex
              -> String         -- ^ expected metatable name
              -> Lua (Maybe a)
toAnyWithName :: StackIndex -> String -> Lua (Maybe a)
toAnyWithName StackIndex
idx String
name = do
  State
l <- Lua State
Lua.state
  Ptr ()
udPtr <- IO (Ptr ()) -> Lua (Ptr ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (String -> (CString -> IO (Ptr ())) -> IO (Ptr ())
forall a. String -> (CString -> IO a) -> IO a
C.withCString String
name (State -> StackIndex -> CString -> IO (Ptr ())
luaL_testudata State
l StackIndex
idx))
  if Ptr ()
udPtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
Ptr.nullPtr
    then Maybe a -> Lua (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    else
      (a -> Maybe a) -> Lua a -> Lua (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Lua a -> Lua (Maybe a))
-> (IO a -> Lua a) -> IO a -> Lua (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Lua a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO a -> Lua (Maybe a)) -> IO a -> Lua (Maybe a)
forall a b. (a -> b) -> a -> b
$
      Ptr (StablePtr a) -> IO (StablePtr a)
forall a. Storable a => Ptr a -> IO a
Storable.peek (Ptr () -> Ptr (StablePtr a)
forall a b. Ptr a -> Ptr b
Ptr.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
StablePtr.deRefStablePtr

-- | Retrieve Haskell data which was pushed to Lua as userdata.
peekAny :: Data a => Lua.StackIndex -> Lua a
peekAny :: StackIndex -> Lua a
peekAny StackIndex
idx = a -> Lua a
forall a. Data a => a -> Lua a
peek' a
forall a. HasCallStack => a
undefined
 where
  peek' :: Data a => a -> Lua a
  peek' :: a -> Lua a
peek' a
x = String -> (StackIndex -> Lua (Maybe a)) -> StackIndex -> Lua a
forall a.
String -> (StackIndex -> Lua (Maybe a)) -> StackIndex -> Lua a
reportValueOnFailure (DataType -> String
dataTypeName (a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
x)) StackIndex -> Lua (Maybe a)
forall a. Data a => StackIndex -> Lua (Maybe a)
toAny StackIndex
idx

-- | Return the default name for userdata to be used when wrapping an object as
-- the given type as userdata.  The argument is never evaluated.
metatableName :: Data a => a -> String
metatableName :: a -> String
metatableName a
x = String
"HSLUA_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DataType -> String
dataTypeName (a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
x)

-- | Function to free the stable pointer in a userdata, ensuring the Haskell
-- value can be garbage collected. This function does not call back into
-- Haskell, making is safe to call even from functions imported as unsafe.
foreign import ccall "&hslua_userdata_gc"
  hslua_userdata_gc_ptr :: Lua.CFunction

-- | See
-- <https://www.lua.org/manual/5.3/manual.html#luaL_testudata luaL_testudata>
foreign import ccall "luaL_testudata"
  luaL_testudata :: Lua.State -> Lua.StackIndex -> C.CString -> IO (Ptr.Ptr ())