{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-|
Module      : HsLua.Core.Auxiliary
Copyright   : © 2007–2012 Gracjan Polak;
              © 2012–2016 Ömer Sinan Ağacan;
              © 2017-2021 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : non-portable (depends on GHC)

Wrappers for the auxiliary library.
-}
module HsLua.Core.Auxiliary
  ( -- * The Auxiliary Library
    dostring
  , dofile
  , getmetafield
  , getmetatable'
  , getsubtable
  , loadbuffer
  , loadfile
  , loadstring
  , newmetatable
  , newstate
  , tostring'
  , traceback
  , where'
    -- ** References
  , getref
  , ref
  , unref
    -- ** Registry fields
  , loaded
  , preload
  ) where

import Control.Monad ((<$!>))
import Data.ByteString (ByteString)
import Data.String (IsString (fromString))
import HsLua.Core.Error (LuaError, throwErrorAsException)
import HsLua.Core.Types
  (LuaE, Name (Name), Status, StackIndex, liftLua, multret, runWith)
import Lua (top)
import Lua.Auxiliary
import Lua.Ersatz.Auxiliary
import Foreign.C (withCString)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr

import qualified Data.ByteString as B
import qualified HsLua.Core.Primary as Lua
import qualified HsLua.Core.Types as Lua
import qualified Foreign.Storable as Storable

-- | Loads and runs the given string.
--
-- Returns 'Lua.OK' on success, or an error if either loading of the
-- string or calling of the thunk failed.
dostring :: ByteString -> LuaE e Status
dostring :: ByteString -> LuaE e Status
dostring ByteString
s = do
  Status
loadRes <- ByteString -> LuaE e Status
forall e. ByteString -> LuaE e Status
loadstring ByteString
s
  if Status
loadRes Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Lua.OK
    then NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
forall e.
NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
Lua.pcall NumArgs
0 NumResults
multret Maybe StackIndex
forall a. Maybe a
Nothing
    else Status -> LuaE e Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
loadRes
{-# INLINABLE dostring #-}

-- | Loads and runs the given file. Note that the filepath is
-- interpreted by Haskell, not Lua. The resulting chunk is named using
-- the UTF8 encoded filepath.
dofile :: FilePath -> LuaE e Status
dofile :: FilePath -> LuaE e Status
dofile FilePath
fp = do
  Status
loadRes <- FilePath -> LuaE e Status
forall e. FilePath -> LuaE e Status
loadfile FilePath
fp
  if Status
loadRes Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Lua.OK
    then NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
forall e.
NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
Lua.pcall NumArgs
0 NumResults
multret Maybe StackIndex
forall a. Maybe a
Nothing
    else Status -> LuaE e Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
loadRes
{-# INLINABLE dofile #-}

-- | Pushes onto the stack the field @e@ from the metatable of the
-- object at index @obj@ and returns the type of the pushed value. If
-- the object does not have a metatable, or if the metatable does not
-- have this field, pushes nothing and returns 'TypeNil'.
--
-- Wraps 'luaL_getmetafield'.
getmetafield :: StackIndex -- ^ obj
             -> Name       -- ^ e
             -> LuaE e Lua.Type
getmetafield :: StackIndex -> Name -> LuaE e Type
getmetafield StackIndex
obj (Name ByteString
name) = (State -> IO Type) -> LuaE e Type
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Type) -> LuaE e Type)
-> (State -> IO Type) -> LuaE e Type
forall a b. (a -> b) -> a -> b
$ \State
l ->
  ByteString -> (CString -> IO Type) -> IO Type
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString ByteString
name ((CString -> IO Type) -> IO Type)
-> (CString -> IO Type) -> IO Type
forall a b. (a -> b) -> a -> b
$! (TypeCode -> Type) -> IO TypeCode -> IO Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeCode -> Type
Lua.toType (IO TypeCode -> IO Type)
-> (CString -> IO TypeCode) -> CString -> IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> StackIndex -> CString -> IO TypeCode
luaL_getmetafield State
l StackIndex
obj
{-# INLINABLE getmetafield #-}

-- | Pushes onto the stack the metatable associated with name @tname@ in
-- the registry (see 'newmetatable') (@nil@ if there is no metatable
-- associated with that name). Returns the type of the pushed value.
--
-- Wraps 'luaL_getmetatable'.
getmetatable' :: Name      -- ^ tname
              -> LuaE e Lua.Type
getmetatable' :: Name -> LuaE e Type
getmetatable' (Name ByteString
tname) = (State -> IO Type) -> LuaE e Type
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Type) -> LuaE e Type)
-> (State -> IO Type) -> LuaE e Type
forall a b. (a -> b) -> a -> b
$ \State
l ->
  ByteString -> (CString -> IO Type) -> IO Type
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString ByteString
tname ((CString -> IO Type) -> IO Type)
-> (CString -> IO Type) -> IO Type
forall a b. (a -> b) -> a -> b
$ (TypeCode -> Type) -> IO TypeCode -> IO Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeCode -> Type
Lua.toType (IO TypeCode -> IO Type)
-> (CString -> IO TypeCode) -> CString -> IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> CString -> IO TypeCode
luaL_getmetatable State
l
{-# INLINABLE getmetatable' #-}

-- | Push referenced value from the table at the given index.
getref :: LuaError e => StackIndex -> Reference -> LuaE e ()
getref :: StackIndex -> Reference -> LuaE e ()
getref StackIndex
idx Reference
ref' = StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
Lua.rawgeti StackIndex
idx (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reference -> CInt
Lua.fromReference Reference
ref'))
{-# INLINABLE getref #-}

-- | Ensures that the value @t[fname]@, where @t@ is the value at index
-- @idx@, is a table, and pushes that table onto the stack. Returns True
-- if it finds a previous table there and False if it creates a new
-- table.
getsubtable :: LuaError e
            => StackIndex   -- ^ idx
            -> Name         -- ^ fname
            -> LuaE e Bool
getsubtable :: StackIndex -> Name -> LuaE e Bool
getsubtable StackIndex
idx fname :: Name
fname@(Name ByteString
namestr) = do
  -- This is a reimplementation of luaL_getsubtable from lauxlib.c.
  StackIndex
idx' <- StackIndex -> LuaE e StackIndex
forall e. StackIndex -> LuaE e StackIndex
Lua.absindex StackIndex
idx
  ByteString -> LuaE e ()
forall e. ByteString -> LuaE e ()
Lua.pushstring ByteString
namestr
  StackIndex -> LuaE e Type
forall e. LuaError e => StackIndex -> LuaE e Type
Lua.gettable StackIndex
idx' LuaE e Type -> (Type -> LuaE e Bool) -> LuaE e Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Type
Lua.TypeTable -> Bool -> LuaE e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Type
_ -> do
      Int -> LuaE e ()
forall e. Int -> LuaE e ()
Lua.pop Int
1
      LuaE e ()
forall e. LuaE e ()
Lua.newtable
      StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
Lua.pushvalue StackIndex
top -- copy to be left at top
      StackIndex -> Name -> LuaE e ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
Lua.setfield StackIndex
idx' Name
fname
      Bool -> LuaE e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
{-# INLINABLE getsubtable #-}

-- | Loads a ByteString as a Lua chunk.
--
-- This function returns the same results as @'Lua.load'@. @name@ is the
-- chunk name, used for debug information and error messages. Note that
-- @name@ is used as a C string, so it may not contain null-bytes.
--
-- Wraps 'luaL_loadbuffer'.
loadbuffer :: ByteString -- ^ Program to load
           -> Name       -- ^ chunk name
           -> LuaE e Status
loadbuffer :: ByteString -> Name -> LuaE e Status
loadbuffer ByteString
bs (Name ByteString
name) = (State -> IO Status) -> LuaE e Status
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Status) -> LuaE e Status)
-> (State -> IO Status) -> LuaE e Status
forall a b. (a -> b) -> a -> b
$ \State
l ->
  ByteString -> (CStringLen -> IO Status) -> IO Status
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.useAsCStringLen ByteString
bs ((CStringLen -> IO Status) -> IO Status)
-> (CStringLen -> IO Status) -> IO Status
forall a b. (a -> b) -> a -> b
$ \(CString
str, Int
len) ->
  ByteString -> (CString -> IO Status) -> IO Status
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString ByteString
name ((CString -> IO Status) -> IO Status)
-> (CString -> IO Status) -> IO Status
forall a b. (a -> b) -> a -> b
$!
    (StatusCode -> Status) -> IO StatusCode -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StatusCode -> Status
Lua.toStatus (IO StatusCode -> IO Status)
-> (CString -> IO StatusCode) -> CString -> IO Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> CString -> CSize -> CString -> IO StatusCode
luaL_loadbuffer State
l CString
str (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
{-# INLINABLE loadbuffer #-}

-- | Loads a file as a Lua chunk. This function uses @lua_load@ (see
-- @'Lua.load'@) to load the chunk in the file named filename. The first
-- line in the file is ignored if it starts with a @#@.
--
-- The string mode works as in function @'Lua.load'@.
--
-- This function returns the same results as @'Lua.load'@, but it has an
-- extra error code @'Lua.ErrFile'@ for file-related errors (e.g., it
-- cannot open or read the file).
--
-- As @'Lua.load'@, this function only loads the chunk; it does not run
-- it.
--
-- Note that the file is opened by Haskell, not Lua.
--
-- See <https://www.lua.org/manual/5.3/manual.html#luaL_loadfile luaL_loadfile>.
loadfile :: FilePath -- ^ filename
         -> LuaE e Status
loadfile :: FilePath -> LuaE e Status
loadfile FilePath
fp = (State -> IO Status) -> LuaE e Status
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Status) -> LuaE e Status)
-> (State -> IO Status) -> LuaE e Status
forall a b. (a -> b) -> a -> b
$ \State
l ->
  FilePath -> (CString -> IO Status) -> IO Status
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
fp ((CString -> IO Status) -> IO Status)
-> (CString -> IO Status) -> IO Status
forall a b. (a -> b) -> a -> b
$! (StatusCode -> Status) -> IO StatusCode -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StatusCode -> Status
Lua.toStatus (IO StatusCode -> IO Status)
-> (CString -> IO StatusCode) -> CString -> IO Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> CString -> IO StatusCode
luaL_loadfile State
l
{-# INLINABLE loadfile #-}

-- | Loads a string as a Lua chunk. This function uses @lua_load@ to
-- load the chunk in the given ByteString. The given string may not
-- contain any NUL characters.
--
-- This function returns the same results as @lua_load@ (see
-- @'Lua.load'@).
--
-- Also as @'Lua.load'@, this function only loads the chunk; it does not
-- run it.
--
-- See
-- <https://www.lua.org/manual/5.3/manual.html#luaL_loadstring luaL_loadstring>.
loadstring :: ByteString -> LuaE e Status
loadstring :: ByteString -> LuaE e Status
loadstring ByteString
s = ByteString -> Name -> LuaE e Status
forall e. ByteString -> Name -> LuaE e Status
loadbuffer ByteString
s (ByteString -> Name
Name ByteString
s)
{-# INLINE loadstring #-}

-- | If the registry already has the key tname, returns @False@.
-- Otherwise, creates a new table to be used as a metatable for
-- userdata, adds to this new table the pair @__name = tname@, adds to
-- the registry the pair @[tname] = new table@, and returns @True@. (The
-- entry @__name@ is used by some error-reporting functions.)
--
-- In both cases pushes onto the stack the final value associated with
-- @tname@ in the registry.
--
-- The value of @tname@ is used as a C string and hence must not contain
-- null bytes.
--
-- Wraps 'luaL_newmetatable'.
newmetatable :: Name -> LuaE e Bool
newmetatable :: Name -> LuaE e Bool
newmetatable (Name ByteString
tname) = (State -> IO Bool) -> LuaE e Bool
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Bool) -> LuaE e Bool)
-> (State -> IO Bool) -> LuaE e Bool
forall a b. (a -> b) -> a -> b
$ \State
l ->
  LuaBool -> Bool
Lua.fromLuaBool (LuaBool -> Bool) -> IO LuaBool -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ByteString -> (CString -> IO LuaBool) -> IO LuaBool
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString ByteString
tname (State -> CString -> IO LuaBool
luaL_newmetatable State
l)
{-# INLINABLE newmetatable #-}

-- | Creates a new Lua state. It calls @lua_newstate@ with an allocator
-- based on the standard C @realloc@ function and then sets a panic
-- function (see <https://www.lua.org/manual/5.3/manual.html#4.6 §4.6>
-- of the Lua 5.3 Reference Manual) that prints an error message to the
-- standard error output in case of fatal errors.
--
-- Wraps 'hsluaL_newstate'. See also:
-- <https://www.lua.org/manual/5.3/manual.html#luaL_newstate luaL_newstate>.
newstate :: IO Lua.State
newstate :: IO State
newstate = IO State
hsluaL_newstate
{-# INLINE newstate #-}

-- | Creates and returns a reference, in the table at index @t@, for the
-- object at the top of the stack (and pops the object).
--
-- A reference is a unique integer key. As long as you do not manually
-- add integer keys into table @t@, @ref@ ensures the uniqueness of the
-- key it returns. You can retrieve an object referred by reference @r@
-- by calling @rawgeti t r@. Function @'unref'@ frees a reference and
-- its associated object.
--
-- If the object at the top of the stack is nil, @'ref'@ returns the
-- constant @'Lua.refnil'@. The constant @'Lua.noref'@ is guaranteed to
-- be different from any reference returned by @'ref'@.
--
-- Wraps 'luaL_ref'.
ref :: StackIndex -> LuaE e Reference
ref :: StackIndex -> LuaE e Reference
ref StackIndex
t = (State -> IO Reference) -> LuaE e Reference
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO Reference) -> LuaE e Reference)
-> (State -> IO Reference) -> LuaE e Reference
forall a b. (a -> b) -> a -> b
$ \State
l -> CInt -> Reference
Lua.toReference (CInt -> Reference) -> IO CInt -> IO Reference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> StackIndex -> IO CInt
luaL_ref State
l StackIndex
t
{-# INLINABLE ref #-}

-- | Converts any Lua value at the given index to a 'ByteString' in a
-- reasonable format. The resulting string is pushed onto the stack and
-- also returned by the function.
--
-- If the value has a metatable with a @__tostring@ field, then
-- @tolstring'@ calls the corresponding metamethod with the value as
-- argument, and uses the result of the call as its result.
--
-- Wraps 'hsluaL_tolstring'.
tostring' :: forall e. LuaError e => StackIndex -> LuaE e B.ByteString
tostring' :: StackIndex -> LuaE e ByteString
tostring' StackIndex
n = do
  State
l <- LuaE e State
forall e. LuaE e State
Lua.state
  IO ByteString -> LuaE e ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO ByteString -> LuaE e ByteString)
-> IO ByteString -> LuaE e ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO ByteString) -> IO ByteString)
-> (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
lenPtr -> do
    CString
cstr <- State -> StackIndex -> Ptr CSize -> IO CString
hsluaL_tolstring State
l StackIndex
n Ptr CSize
lenPtr
    if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
      then State -> LuaE e ByteString -> IO ByteString
forall e a. State -> LuaE e a -> IO a
runWith @e State
l LuaE e ByteString
forall e a. LuaError e => LuaE e a
throwErrorAsException
      else do
        CSize
cstrLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
Storable.peek Ptr CSize
lenPtr
        CStringLen -> IO ByteString
B.packCStringLen (CString
cstr, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cstrLen)
{-# INLINABLE tostring' #-}

-- | Creates and pushes a traceback of the stack L1. If a message is
-- given it appended at the beginning of the traceback. The level
-- parameter tells at which level to start the traceback.
--
-- Wraps 'luaL_traceback'.
traceback :: Lua.State -> Maybe ByteString -> Int -> LuaE e ()
traceback :: State -> Maybe ByteString -> Int -> LuaE e ()
traceback State
l1 Maybe ByteString
msg Int
level = (State -> IO ()) -> LuaE e ()
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO ()) -> LuaE e ()) -> (State -> IO ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \State
l ->
  case Maybe ByteString
msg of
    Maybe ByteString
Nothing -> State -> State -> CString -> CInt -> IO ()
luaL_traceback State
l State
l1 CString
forall a. Ptr a
nullPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
level)
    Just ByteString
msg' -> ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString ByteString
msg' ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cstr ->
      State -> State -> CString -> CInt -> IO ()
luaL_traceback State
l State
l1 CString
cstr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
level)
{-# INLINABLE traceback #-}

-- | Releases reference @'ref'@ from the table at index @idx@ (see
-- @'ref'@). The entry is removed from the table, so that the referred
-- object can be collected. The reference @'ref'@ is also freed to be
-- used again.
--
-- Wraps 'luaL_unref'. See also:
-- <https://www.lua.org/manual/5.3/manual.html#luaL_unref luaL_unref>.
unref :: StackIndex -- ^ idx
      -> Reference  -- ^ ref
      -> LuaE e ()
unref :: StackIndex -> Reference -> LuaE e ()
unref StackIndex
idx Reference
r = (State -> IO ()) -> LuaE e ()
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO ()) -> LuaE e ()) -> (State -> IO ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \State
l ->
  State -> StackIndex -> CInt -> IO ()
luaL_unref State
l StackIndex
idx (Reference -> CInt
Lua.fromReference Reference
r)
{-# INLINABLE unref #-}

-- | Pushes onto the stack a string identifying the current position of
-- the control at level @lvl@ in the call stack. Typically this string
-- has the following format:
--
-- > chunkname:currentline:
--
-- Level 0 is the running function, level 1 is the function that called
-- the running function, etc.
--
-- This function is used to build a prefix for error messages.
where' :: Int        -- ^ lvl
       -> LuaE e ()
where' :: Int -> LuaE e ()
where' Int
lvl = (State -> IO ()) -> LuaE e ()
forall a e. (State -> IO a) -> LuaE e a
liftLua ((State -> IO ()) -> LuaE e ()) -> (State -> IO ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \State
l -> State -> CInt -> IO ()
luaL_where State
l (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lvl)
{-# INLINABLE where' #-}

--
-- Registry fields
--

-- | Key to the registry field that holds the table of loaded modules.
loaded :: Name
loaded :: Name
loaded = FilePath -> Name
forall a. IsString a => FilePath -> a
fromString FilePath
loadedTableRegistryField

-- | Key to the registry field that holds the table of loader functions.
preload :: Name
preload :: Name
preload = FilePath -> Name
forall a. IsString a => FilePath -> a
fromString FilePath
preloadTableRegistryField