{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-|
Module      : HsLua.ObjectOrientation.Generic
Copyright   : © 2021-2024 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>

This module provides types and functions to use Haskell values as
userdata objects in Lua. These objects wrap a Haskell value and provide
methods and properties to interact with the Haskell value.

The terminology in this module refers to the userdata values as /UD
objects/, and to their type as /UD type/.
-}
module HsLua.ObjectOrientation.Generic
  ( UDTypeGeneric (..)
    -- * Defining types
  , deftypeGeneric'
    -- ** Methods
  , methodGeneric
    -- ** Properties
  , property
  , property'
  , possibleProperty
  , possibleProperty'
  , readonly
  , readonly'
    -- ** Aliases
  , alias
    -- ** Type extension
  , UDTypeHooks (..)
  , emptyHooks
    -- * Marshaling
  , peekUDGeneric
  , pushUDGeneric
  , initType
    -- * Type docs
  , udDocs
  , udTypeSpec
    -- * Helper types for building
  , Member
  , Property (..)
  , Operation (..)
  , Possible (..)
  , Alias
  , AliasIndex (..)
  ) where

import Control.Monad (forM_, void, when)
import Data.Maybe (mapMaybe)
import Data.Map (Map)
import Data.String (IsString (..))
import Data.Text (Text)
import Foreign.Ptr (FunPtr)
import HsLua.Core as Lua
import HsLua.Marshalling
import HsLua.ObjectOrientation.Operation
import HsLua.Typing ( TypeDocs (..), TypeSpec (..), anyType, userdataType )
import qualified Data.Map.Strict as Map
import qualified HsLua.Core.Unsafe as Unsafe
import qualified HsLua.Core.Utf8 as Utf8

-- | A userdata type, capturing the behavior of Lua objects that wrap
-- Haskell values. The type name must be unique; once the type has been
-- used to push or retrieve a value, the behavior can no longer be
-- modified through this type.
--
-- This type includes methods to define how the object should behave as
-- a read-only list of type @itemtype@.
data UDTypeGeneric e fn a = UDType
  { forall e fn a. UDTypeGeneric e fn a -> Name
udName          :: Name
  , forall e fn a. UDTypeGeneric e fn a -> [(Operation, fn)]
udOperations    :: [(Operation, fn)]
  , forall e fn a. UDTypeGeneric e fn a -> Map Name (Property e a)
udProperties    :: Map Name (Property e a)
  , forall e fn a. UDTypeGeneric e fn a -> Map Name fn
udMethods       :: Map Name fn
  , forall e fn a. UDTypeGeneric e fn a -> Map AliasIndex Alias
udAliases       :: Map AliasIndex Alias
  , forall e fn a. UDTypeGeneric e fn a -> UDTypeHooks e fn a
udHooks         :: UDTypeHooks e fn a
  , forall e fn a. UDTypeGeneric e fn a -> fn -> LuaE e ()
udFnPusher      :: fn -> LuaE e ()
  }

-- | Extensions for userdata types.
data UDTypeHooks e fn a =
  UDTypeHooks
  { forall e fn a. UDTypeHooks e fn a -> Int
hookUservalues :: Int
    -- ^ Number of uservalues required for this extension, *including* the
    -- uservalue for the default caching table.

  , forall e fn a. UDTypeHooks e fn a -> LuaE e ()
hookMetatableSetup :: LuaE e ()
    -- ^ Run after the metatable has been set up; the new metatable is
    -- at the top of the stack when this hook is run.

  , forall e fn a. UDTypeHooks e fn a -> a -> StackIndex -> Peek e a
hookPeekUD :: a
               -> StackIndex
               -> Peek e a
    -- ^ Peek extra data and modify the peeked object

  , forall e fn a. UDTypeHooks e fn a -> a -> LuaE e ()
hookPushUD :: a -> LuaE e ()
    -- ^ Push extra data
  }

-- | No extension.
emptyHooks :: UDTypeHooks e fn a
emptyHooks :: forall e fn a. UDTypeHooks e fn a
emptyHooks = UDTypeHooks
  { hookMetatableSetup :: LuaE e ()
hookMetatableSetup = () -> LuaE e ()
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  , hookPeekUD :: a -> StackIndex -> Peek e a
hookPeekUD = \a
x StackIndex
_idx -> a -> Peek e a
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

  , hookPushUD :: a -> LuaE e ()
hookPushUD = \a
_x -> () -> LuaE e ()
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  , hookUservalues :: Int
hookUservalues = Int
1
  }

-- | Defines a new "Lua type" and sets the behavior of the Lua object
-- instances. It's possible to pass custom type extensions, which modify
-- the default object behavior. Furthermore, the /function pusher/
-- parameter controls how functions are marshaled to Lua.
--
-- Note that the type name must be unique.
deftypeGeneric' :: Pusher e fn          -- ^ function pusher
                -> Name                 -- ^ type name
                -> [(Operation, fn)]    -- ^ operations
                -> [Member e fn a]      -- ^ methods
                -> UDTypeHooks e fn a   -- ^ behavior modifying hooks
                -> UDTypeGeneric e fn a
deftypeGeneric' :: forall e fn a.
Pusher e fn
-> Name
-> [(Operation, fn)]
-> [Member e fn a]
-> UDTypeHooks e fn a
-> UDTypeGeneric e fn a
deftypeGeneric' Pusher e fn
pushFunction Name
name [(Operation, fn)]
ops [Member e fn a]
members UDTypeHooks e fn a
extension = UDType
  { udName :: Name
udName          = Name
name
  , udOperations :: [(Operation, fn)]
udOperations    = [(Operation, fn)]
ops
  , udProperties :: Map Name (Property e a)
udProperties    = [(Name, Property e a)] -> Map Name (Property e a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Property e a)] -> Map Name (Property e a))
-> [(Name, Property e a)] -> Map Name (Property e a)
forall a b. (a -> b) -> a -> b
$ (Member e fn a -> Maybe (Name, Property e a))
-> [Member e fn a] -> [(Name, Property e a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Member e fn a -> Maybe (Name, Property e a)
forall {e} {fn} {a}. Member e fn a -> Maybe (Name, Property e a)
mbproperties [Member e fn a]
members
  , udMethods :: Map Name fn
udMethods       = [(Name, fn)] -> Map Name fn
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, fn)] -> Map Name fn) -> [(Name, fn)] -> Map Name fn
forall a b. (a -> b) -> a -> b
$ (Member e fn a -> Maybe (Name, fn))
-> [Member e fn a] -> [(Name, fn)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Member e fn a -> Maybe (Name, fn)
forall {e} {b} {a}. Member e b a -> Maybe (Name, b)
mbmethods [Member e fn a]
members
  , udAliases :: Map AliasIndex Alias
udAliases       = [(AliasIndex, Alias)] -> Map AliasIndex Alias
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(AliasIndex, Alias)] -> Map AliasIndex Alias)
-> [(AliasIndex, Alias)] -> Map AliasIndex Alias
forall a b. (a -> b) -> a -> b
$ (Member e fn a -> Maybe (AliasIndex, Alias))
-> [Member e fn a] -> [(AliasIndex, Alias)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Member e fn a -> Maybe (AliasIndex, Alias)
forall {e} {fn} {a}. Member e fn a -> Maybe (AliasIndex, Alias)
mbaliases [Member e fn a]
members
  , udHooks :: UDTypeHooks e fn a
udHooks         = UDTypeHooks e fn a
extension
  , udFnPusher :: Pusher e fn
udFnPusher      = Pusher e fn
pushFunction
  }
  where
    mbproperties :: Member e fn a -> Maybe (Name, Property e a)
mbproperties = \case
      MemberProperty Name
n Property e a
p -> (Name, Property e a) -> Maybe (Name, Property e a)
forall a. a -> Maybe a
Just (Name
n, Property e a
p)
      Member e fn a
_ -> Maybe (Name, Property e a)
forall a. Maybe a
Nothing
    mbmethods :: Member e b a -> Maybe (Name, b)
mbmethods = \case
      MemberMethod Name
n b
m -> (Name, b) -> Maybe (Name, b)
forall a. a -> Maybe a
Just (Name
n, b
m)
      Member e b a
_ -> Maybe (Name, b)
forall a. Maybe a
Nothing
    mbaliases :: Member e fn a -> Maybe (AliasIndex, Alias)
mbaliases = \case
      MemberAlias AliasIndex
n Alias
a -> (AliasIndex, Alias) -> Maybe (AliasIndex, Alias)
forall a. a -> Maybe a
Just (AliasIndex
n, Alias
a)
      Member e fn a
_ -> Maybe (AliasIndex, Alias)
forall a. Maybe a
Nothing

-- | A read- and writable property on a UD object.
data Property e a = Property
  { forall e a. Property e a -> a -> LuaE e NumResults
propertyGet :: a -> LuaE e NumResults
  , forall e a. Property e a -> Maybe (StackIndex -> a -> LuaE e a)
propertySet :: Maybe (StackIndex -> a -> LuaE e a)
  , forall e a. Property e a -> Text
propertyDescription :: Text
  , forall e a. Property e a -> TypeSpec
propertyType :: TypeSpec
  }

-- | Alias for a different property of this or of a nested object.
type Alias = [AliasIndex]

-- | Index types allowed in aliases (strings and integers)
data AliasIndex
  = StringIndex Name
  | IntegerIndex Lua.Integer
  deriving (AliasIndex -> AliasIndex -> Bool
(AliasIndex -> AliasIndex -> Bool)
-> (AliasIndex -> AliasIndex -> Bool) -> Eq AliasIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AliasIndex -> AliasIndex -> Bool
== :: AliasIndex -> AliasIndex -> Bool
$c/= :: AliasIndex -> AliasIndex -> Bool
/= :: AliasIndex -> AliasIndex -> Bool
Eq, Eq AliasIndex
Eq AliasIndex =>
(AliasIndex -> AliasIndex -> Ordering)
-> (AliasIndex -> AliasIndex -> Bool)
-> (AliasIndex -> AliasIndex -> Bool)
-> (AliasIndex -> AliasIndex -> Bool)
-> (AliasIndex -> AliasIndex -> Bool)
-> (AliasIndex -> AliasIndex -> AliasIndex)
-> (AliasIndex -> AliasIndex -> AliasIndex)
-> Ord AliasIndex
AliasIndex -> AliasIndex -> Bool
AliasIndex -> AliasIndex -> Ordering
AliasIndex -> AliasIndex -> AliasIndex
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AliasIndex -> AliasIndex -> Ordering
compare :: AliasIndex -> AliasIndex -> Ordering
$c< :: AliasIndex -> AliasIndex -> Bool
< :: AliasIndex -> AliasIndex -> Bool
$c<= :: AliasIndex -> AliasIndex -> Bool
<= :: AliasIndex -> AliasIndex -> Bool
$c> :: AliasIndex -> AliasIndex -> Bool
> :: AliasIndex -> AliasIndex -> Bool
$c>= :: AliasIndex -> AliasIndex -> Bool
>= :: AliasIndex -> AliasIndex -> Bool
$cmax :: AliasIndex -> AliasIndex -> AliasIndex
max :: AliasIndex -> AliasIndex -> AliasIndex
$cmin :: AliasIndex -> AliasIndex -> AliasIndex
min :: AliasIndex -> AliasIndex -> AliasIndex
Ord)

instance IsString AliasIndex where
  fromString :: String -> AliasIndex
fromString = Name -> AliasIndex
StringIndex (Name -> AliasIndex) -> (String -> Name) -> String -> AliasIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
forall a. IsString a => String -> a
fromString

-- | A type member, either a method or a variable.
data Member e fn a
  = MemberProperty Name (Property e a)
  | MemberMethod Name fn
  | MemberAlias AliasIndex Alias

-- | Use a documented function as an object method.
methodGeneric :: Name -> fn -> Member e fn a
methodGeneric :: forall fn e a. Name -> fn -> Member e fn a
methodGeneric = Name -> fn -> Member e fn a
forall e fn a. Name -> fn -> Member e fn a
MemberMethod

-- | A property or method which may be available in some instances but
-- not in others.
data Possible a
  = Actual a
  | Absent

-- | Declares a new read- and writable typed property.
property' :: LuaError e
          => Name                       -- ^ property name
          -> TypeSpec                   -- ^ property type
          -> Text                       -- ^ property description
          -> (Pusher e b, a -> b)       -- ^ how to get the property value
          -> (Peeker e b, a -> b -> a)  -- ^ how to set a new property value
          -> Member e fn a
property' :: forall e b a fn.
LuaError e =>
Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> b)
-> (Peeker e b, a -> b -> a)
-> Member e fn a
property' Name
name TypeSpec
typespec Text
desc (Pusher e b
push, a -> b
get) (Peeker e b
peek, a -> b -> a
set) =
  Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
forall e b a fn.
LuaError e =>
Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
possibleProperty' Name
name TypeSpec
typespec Text
desc
    (Pusher e b
push, b -> Possible b
forall a. a -> Possible a
Actual (b -> Possible b) -> (a -> b) -> a -> Possible b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)
    (Peeker e b
peek, \a
a b
b -> a -> Possible a
forall a. a -> Possible a
Actual (a -> b -> a
set a
a b
b))

-- | Declares a new read- and writable property.
property :: LuaError e
         => Name                       -- ^ property name
         -> Text                       -- ^ property description
         -> (Pusher e b, a -> b)       -- ^ how to get the property value
         -> (Peeker e b, a -> b -> a)  -- ^ how to set a new property value
         -> Member e fn a
property :: forall e b a fn.
LuaError e =>
Name
-> Text
-> (Pusher e b, a -> b)
-> (Peeker e b, a -> b -> a)
-> Member e fn a
property Name
name Text
desc (Pusher e b
push, a -> b
get) (Peeker e b
peek, a -> b -> a
set) =
  Name
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
forall e b a fn.
LuaError e =>
Name
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
possibleProperty Name
name Text
desc
    (Pusher e b
push, b -> Possible b
forall a. a -> Possible a
Actual (b -> Possible b) -> (a -> b) -> a -> Possible b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)
    (Peeker e b
peek, \a
a b
b -> a -> Possible a
forall a. a -> Possible a
Actual (a -> b -> a
set a
a b
b))

-- | Declares a new read- and writable property which is not always
-- available.
possibleProperty :: LuaError e
  => Name                               -- ^ property name
  -> Text                               -- ^ property description
  -> (Pusher e b, a -> Possible b)      -- ^ how to get the property value
  -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value
  -> Member e fn a
possibleProperty :: forall e b a fn.
LuaError e =>
Name
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
possibleProperty Name
name = Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
forall e b a fn.
LuaError e =>
Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
possibleProperty' Name
name TypeSpec
anyType

-- | Declares a new read- and writable property which is not always
-- available.
possibleProperty' :: LuaError e
  => Name                               -- ^ property name
  -> TypeSpec                           -- ^ type of the property value
  -> Text                               -- ^ property description
  -> (Pusher e b, a -> Possible b)      -- ^ how to get the property value
  -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value
  -> Member e fn a
possibleProperty' :: forall e b a fn.
LuaError e =>
Name
-> TypeSpec
-> Text
-> (Pusher e b, a -> Possible b)
-> (Peeker e b, a -> b -> Possible a)
-> Member e fn a
possibleProperty' Name
name TypeSpec
typespec Text
desc (Pusher e b
push, a -> Possible b
get) (Peeker e b
peek, a -> b -> Possible a
set) =
  Name -> Property e a -> Member e fn a
forall e fn a. Name -> Property e a -> Member e fn a
MemberProperty Name
name (Property e a -> Member e fn a) -> Property e a -> Member e fn a
forall a b. (a -> b) -> a -> b
$
  Property
  { propertyGet :: a -> LuaE e NumResults
propertyGet = \a
x -> do
      case a -> Possible b
get a
x of
        Actual b
y -> CInt -> NumResults
NumResults CInt
1 NumResults -> LuaE e () -> LuaE e NumResults
forall a b. a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Pusher e b
push b
y
        Possible b
Absent   -> NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> NumResults
NumResults CInt
0)
  , propertySet :: Maybe (StackIndex -> a -> LuaE e a)
propertySet = (StackIndex -> a -> LuaE e a)
-> Maybe (StackIndex -> a -> LuaE e a)
forall a. a -> Maybe a
Just ((StackIndex -> a -> LuaE e a)
 -> Maybe (StackIndex -> a -> LuaE e a))
-> (StackIndex -> a -> LuaE e a)
-> Maybe (StackIndex -> a -> LuaE e a)
forall a b. (a -> b) -> a -> b
$ \StackIndex
idx a
x -> do
      value  <- Peek e b -> LuaE e b
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek e b -> LuaE e b) -> Peek e b -> LuaE e b
forall a b. (a -> b) -> a -> b
$ Peeker e b
peek StackIndex
idx
      case set x value of
        Actual a
y -> a -> LuaE e a
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
        Possible a
Absent   -> String -> LuaE e a
forall e a. LuaError e => String -> LuaE e a
failLua (String -> LuaE e a) -> String -> LuaE e a
forall a b. (a -> b) -> a -> b
$ String
"Trying to set unavailable property "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
Utf8.toString (Name -> ByteString
fromName Name
name)
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
  , propertyType :: TypeSpec
propertyType = TypeSpec
typespec
  , propertyDescription :: Text
propertyDescription = Text
desc
  }

-- | Creates a read-only object property. Attempts to set the value will
-- cause an error.
readonly' :: Name                 -- ^ property name
          -> TypeSpec             -- ^ property type
          -> Text                 -- ^ property description
          -> (Pusher e b, a -> b) -- ^ how to get the property value
          -> Member e fn a
readonly' :: forall e b a fn.
Name -> TypeSpec -> Text -> (Pusher e b, a -> b) -> Member e fn a
readonly' Name
name TypeSpec
typespec Text
desc (Pusher e b
push, a -> b
get) = Name -> Property e a -> Member e fn a
forall e fn a. Name -> Property e a -> Member e fn a
MemberProperty Name
name (Property e a -> Member e fn a) -> Property e a -> Member e fn a
forall a b. (a -> b) -> a -> b
$
  Property
  { propertyGet :: a -> LuaE e NumResults
propertyGet = \a
x -> do
      Pusher e b
push Pusher e b -> Pusher e b
forall a b. (a -> b) -> a -> b
$ a -> b
get a
x
      NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> NumResults
NumResults CInt
1)
  , propertySet :: Maybe (StackIndex -> a -> LuaE e a)
propertySet = Maybe (StackIndex -> a -> LuaE e a)
forall a. Maybe a
Nothing
  , propertyType :: TypeSpec
propertyType = TypeSpec
typespec
  , propertyDescription :: Text
propertyDescription = Text
desc
  }

-- | Creates a read-only object property. Attempts to set the value will
-- cause an error.
readonly :: Name                 -- ^ property name
         -> Text                 -- ^ property description
         -> (Pusher e b, a -> b) -- ^ how to get the property value
         -> Member e fn a
readonly :: forall e b a fn.
Name -> Text -> (Pusher e b, a -> b) -> Member e fn a
readonly Name
name = Name -> TypeSpec -> Text -> (Pusher e b, a -> b) -> Member e fn a
forall e b a fn.
Name -> TypeSpec -> Text -> (Pusher e b, a -> b) -> Member e fn a
readonly' Name
name TypeSpec
anyType

-- | Define an alias for another, possibly nested, property.
alias :: AliasIndex    -- ^ property alias
      -> Text          -- ^ description
      -> [AliasIndex]  -- ^ sequence of nested properties
      -> Member e fn a
alias :: forall e fn a. AliasIndex -> Text -> Alias -> Member e fn a
alias AliasIndex
name Text
_desc = AliasIndex -> Alias -> Member e fn a
forall e fn a. AliasIndex -> Alias -> Member e fn a
MemberAlias AliasIndex
name

-- | Ensures that the type has been fully initialized, i.e., that all
-- metatables have been created and stored in the registry. Returns the
-- name of the initialized type.
initType :: LuaError e
         => UDTypeGeneric e fn a
         -> LuaE e Name
initType :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e Name
initType UDTypeGeneric e fn a
ty = do
  UDTypeGeneric e fn a -> LuaE e ()
forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushUDMetatable UDTypeGeneric e fn a
ty
  Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
  Name -> LuaE e Name
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return (UDTypeGeneric e fn a -> Name
forall e fn a. UDTypeGeneric e fn a -> Name
udName UDTypeGeneric e fn a
ty)

-- | Pushes the metatable for the given type to the Lua stack. Creates
-- the new table afresh on the first time it is needed, and retrieves it
-- from the registry after that.
--
--
-- A @hook@ can be used to perform additional setup operations. The
-- function is called as the last step after the type metatable has been
-- initialized: the fully initialized metatable will be at the top of
-- the stack at that point. Note that the hook will /not/ be called if
-- the type's metatable already existed before this function was
-- invoked.
pushUDMetatable
  :: forall e fn a. LuaError e
  => UDTypeGeneric e fn a
  -> LuaE e ()
pushUDMetatable :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushUDMetatable UDTypeGeneric e fn a
ty = do
  created <- Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newudmetatable (UDTypeGeneric e fn a -> Name
forall e fn a. UDTypeGeneric e fn a -> Name
udName UDTypeGeneric e fn a
ty)
  when created $ do
    add (metamethodName Index)    $ pushcfunction hslua_udindex_ptr
    add (metamethodName Newindex) $ pushcfunction hslua_udnewindex_ptr
    add (metamethodName Pairs)    $ pushHaskellFunction (pairsFunction ty)
    forM_ (udOperations ty) $ \(Operation
op, fn
f) -> do
      Name -> LuaE e () -> LuaE e ()
add (Operation -> Name
metamethodName Operation
op) (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ UDTypeGeneric e fn a -> fn -> LuaE e ()
forall e fn a. UDTypeGeneric e fn a -> fn -> LuaE e ()
udFnPusher UDTypeGeneric e fn a
ty fn
f
    add "getters" $ pushGetters ty
    add "setters" $ pushSetters ty
    add "methods" $ pushMethods ty
    add "aliases" $ pushAliases ty
    hookMetatableSetup (udHooks ty)
  where
    add :: Name -> LuaE e () -> LuaE e ()
    add :: Name -> LuaE e () -> LuaE e ()
add Name
name LuaE e ()
op = do
      Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
      LuaE e ()
op
      StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

-- | Retrieves a key from a Haskell-data holding userdata value.
--
-- Does the following, in order, and returns the first non-nil result:
--
--   - Checks the userdata's uservalue table for the given key;
--
--   - Looks up a @getter@ for the key and calls it with the userdata
--     and key as arguments;
--
--   - Looks up the key in the table in the @methods@ metafield.
foreign import ccall "hslobj.c &hslua_udindex"
  hslua_udindex_ptr :: FunPtr (State -> IO NumResults)

-- | Sets a new value in the userdata caching table via a setter
-- functions.
--
-- The actual assignment is performed by a setter function stored in the
-- @setter@ metafield. Throws an error if no setter function can be
-- found.
foreign import ccall "hslobj.c &hslua_udnewindex"
  hslua_udnewindex_ptr :: FunPtr (State -> IO NumResults)

-- | Sets a value in the userdata's caching table (uservalue). Takes the
-- same arguments as a @__newindex@ function.
foreign import ccall "hslobj.c &hslua_udsetter"
  hslua_udsetter_ptr :: FunPtr (State -> IO NumResults)

-- | Throws an error nothing that the given key is read-only.
foreign import ccall "hslobj.c &hslua_udreadonly"
  hslua_udreadonly_ptr :: FunPtr (State -> IO NumResults)

-- | Pushes the metatable's @getters@ field table.
pushGetters
  :: LuaError e
  => UDTypeGeneric e fn a -> LuaE e ()
pushGetters :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushGetters UDTypeGeneric e fn a
ty = do
  LuaE e ()
forall e. LuaE e ()
newtable
  LuaE e (Map Name ()) -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e (Map Name ()) -> LuaE e ())
-> LuaE e (Map Name ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ ((Name -> Property e a -> LuaE e ())
 -> Map Name (Property e a) -> LuaE e (Map Name ()))
-> Map Name (Property e a)
-> (Name -> Property e a -> LuaE e ())
-> LuaE e (Map Name ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Property e a -> LuaE e ())
-> Map Name (Property e a) -> LuaE e (Map Name ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (UDTypeGeneric e fn a -> Map Name (Property e a)
forall e fn a. UDTypeGeneric e fn a -> Map Name (Property e a)
udProperties UDTypeGeneric e fn a
ty) ((Name -> Property e a -> LuaE e ()) -> LuaE e (Map Name ()))
-> (Name -> Property e a -> LuaE e ()) -> LuaE e (Map Name ())
forall a b. (a -> b) -> a -> b
$ \Name
name Property e a
prop -> do
    Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
    HaskellFunction e -> LuaE e ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction (HaskellFunction e -> LuaE e ()) -> HaskellFunction e -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ Peek e a -> LuaE e a
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (UDTypeGeneric e fn a -> Peeker e a
forall e fn a. LuaError e => UDTypeGeneric e fn a -> Peeker e a
peekUDGeneric UDTypeGeneric e fn a
ty StackIndex
1) LuaE e a -> (a -> HaskellFunction e) -> HaskellFunction e
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Property e a -> a -> HaskellFunction e
forall e a. Property e a -> a -> LuaE e NumResults
propertyGet Property e a
prop
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

-- | Pushes the metatable's @setters@ field table.
pushSetters :: LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushSetters :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushSetters UDTypeGeneric e fn a
ty = do
  LuaE e ()
forall e. LuaE e ()
newtable
  LuaE e (Map Name ()) -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e (Map Name ()) -> LuaE e ())
-> LuaE e (Map Name ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ ((Name -> Property e a -> LuaE e ())
 -> Map Name (Property e a) -> LuaE e (Map Name ()))
-> Map Name (Property e a)
-> (Name -> Property e a -> LuaE e ())
-> LuaE e (Map Name ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Property e a -> LuaE e ())
-> Map Name (Property e a) -> LuaE e (Map Name ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (UDTypeGeneric e fn a -> Map Name (Property e a)
forall e fn a. UDTypeGeneric e fn a -> Map Name (Property e a)
udProperties UDTypeGeneric e fn a
ty) ((Name -> Property e a -> LuaE e ()) -> LuaE e (Map Name ()))
-> (Name -> Property e a -> LuaE e ()) -> LuaE e (Map Name ())
forall a b. (a -> b) -> a -> b
$ \Name
name Property e a
prop -> do
    Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
    CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction (CFunction -> LuaE e ()) -> CFunction -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ case Property e a -> Maybe (StackIndex -> a -> LuaE e a)
forall e a. Property e a -> Maybe (StackIndex -> a -> LuaE e a)
propertySet Property e a
prop of
      Just StackIndex -> a -> LuaE e a
_  -> CFunction
hslua_udsetter_ptr
      Maybe (StackIndex -> a -> LuaE e a)
Nothing -> CFunction
hslua_udreadonly_ptr
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

-- | Pushes the metatable's @methods@ field table.
pushMethods :: LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushMethods :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushMethods UDTypeGeneric e fn a
ty = do
  LuaE e ()
forall e. LuaE e ()
newtable
  LuaE e (Map Name ()) -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e (Map Name ()) -> LuaE e ())
-> LuaE e (Map Name ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ ((Name -> fn -> LuaE e ()) -> Map Name fn -> LuaE e (Map Name ()))
-> Map Name fn -> (Name -> fn -> LuaE e ()) -> LuaE e (Map Name ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> fn -> LuaE e ()) -> Map Name fn -> LuaE e (Map Name ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (UDTypeGeneric e fn a -> Map Name fn
forall e fn a. UDTypeGeneric e fn a -> Map Name fn
udMethods UDTypeGeneric e fn a
ty) ((Name -> fn -> LuaE e ()) -> LuaE e (Map Name ()))
-> (Name -> fn -> LuaE e ()) -> LuaE e (Map Name ())
forall a b. (a -> b) -> a -> b
$ \Name
name fn
fn -> do
    Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
    UDTypeGeneric e fn a -> fn -> LuaE e ()
forall e fn a. UDTypeGeneric e fn a -> fn -> LuaE e ()
udFnPusher UDTypeGeneric e fn a
ty fn
fn
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

pushAliases :: LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushAliases :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushAliases UDTypeGeneric e fn a
ty = do
  LuaE e ()
forall e. LuaE e ()
newtable
  LuaE e (Map AliasIndex ()) -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e (Map AliasIndex ()) -> LuaE e ())
-> LuaE e (Map AliasIndex ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ ((AliasIndex -> Alias -> LuaE e ())
 -> Map AliasIndex Alias -> LuaE e (Map AliasIndex ()))
-> Map AliasIndex Alias
-> (AliasIndex -> Alias -> LuaE e ())
-> LuaE e (Map AliasIndex ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (AliasIndex -> Alias -> LuaE e ())
-> Map AliasIndex Alias -> LuaE e (Map AliasIndex ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (UDTypeGeneric e fn a -> Map AliasIndex Alias
forall e fn a. UDTypeGeneric e fn a -> Map AliasIndex Alias
udAliases UDTypeGeneric e fn a
ty) ((AliasIndex -> Alias -> LuaE e ()) -> LuaE e (Map AliasIndex ()))
-> (AliasIndex -> Alias -> LuaE e ()) -> LuaE e (Map AliasIndex ())
forall a b. (a -> b) -> a -> b
$ \AliasIndex
name Alias
propSeq -> do
    Pusher e AliasIndex
forall e. Pusher e AliasIndex
pushAliasIndex AliasIndex
name
    Pusher e AliasIndex -> Alias -> LuaE e ()
forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList Pusher e AliasIndex
forall e. Pusher e AliasIndex
pushAliasIndex Alias
propSeq
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

pushAliasIndex :: Pusher e AliasIndex
pushAliasIndex :: forall e. Pusher e AliasIndex
pushAliasIndex = \case
  StringIndex Name
name -> Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
  IntegerIndex Integer
n   -> Integer -> LuaE e ()
forall a e. (Integral a, Show a) => a -> LuaE e ()
pushIntegral Integer
n

-- | Pushes the function used to iterate over the object's key-value
-- pairs in a generic *for* loop.
pairsFunction
  :: LuaError err
  => UDTypeGeneric err fn a -> LuaE err NumResults
pairsFunction :: forall err fn a.
LuaError err =>
UDTypeGeneric err fn a -> LuaE err NumResults
pairsFunction UDTypeGeneric err fn a
ty = do
  obj <- Peek err a -> LuaE err a
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek err a -> LuaE err a) -> Peek err a -> LuaE err a
forall a b. (a -> b) -> a -> b
$ UDTypeGeneric err fn a -> Peeker err a
forall e fn a. LuaError e => UDTypeGeneric e fn a -> Peeker e a
peekUDGeneric UDTypeGeneric err fn a
ty (CInt -> StackIndex
nthBottom CInt
1)
  let pushMember = \case
        MemberProperty Name
name Property err a
prop -> do
          Name -> LuaE err ()
forall e. Name -> LuaE e ()
pushName Name
name
          getresults <- Property err a -> a -> LuaE err NumResults
forall e a. Property e a -> a -> LuaE e NumResults
propertyGet Property err a
prop a
obj
          if getresults == 0
            then 0 <$ pop 1  -- property is absent, don't push anything
            else return $ getresults + 1
        MemberMethod Name
name fn
f -> do
          Name -> LuaE err ()
forall e. Name -> LuaE e ()
pushName Name
name
          UDTypeGeneric err fn a -> fn -> LuaE err ()
forall e fn a. UDTypeGeneric e fn a -> fn -> LuaE e ()
udFnPusher UDTypeGeneric err fn a
ty fn
f
          NumResults -> LuaE err NumResults
forall a. a -> LuaE err a
forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
2
        MemberAlias{} -> String -> LuaE err NumResults
forall a. String -> LuaE err a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"aliases are not full properties"
  pushIterator pushMember $
    map (uncurry MemberProperty) (Map.toAscList (udProperties ty)) ++
    map (uncurry MemberMethod) (Map.toAscList (udMethods ty))

-- | Pushes a userdata value of the given type.
pushUDGeneric
  :: LuaError e
  => UDTypeGeneric e fn a                -- ^ userdata type
  -> a                                   -- ^ value to push
  -> LuaE e ()
pushUDGeneric :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> a -> LuaE e ()
pushUDGeneric UDTypeGeneric e fn a
ty a
x = do
  a -> Int -> LuaE e ()
forall a e. a -> Int -> LuaE e ()
newhsuserdatauv a
x (UDTypeHooks e fn a -> Int
forall e fn a. UDTypeHooks e fn a -> Int
hookUservalues (UDTypeGeneric e fn a -> UDTypeHooks e fn a
forall e fn a. UDTypeGeneric e fn a -> UDTypeHooks e fn a
udHooks UDTypeGeneric e fn a
ty))
  UDTypeGeneric e fn a -> LuaE e ()
forall e fn a. LuaError e => UDTypeGeneric e fn a -> LuaE e ()
pushUDMetatable UDTypeGeneric e fn a
ty
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
2)
  UDTypeHooks e fn a -> a -> LuaE e ()
forall e fn a. UDTypeHooks e fn a -> a -> LuaE e ()
hookPushUD (UDTypeGeneric e fn a -> UDTypeHooks e fn a
forall e fn a. UDTypeGeneric e fn a -> UDTypeHooks e fn a
udHooks UDTypeGeneric e fn a
ty) a
x

-- | Retrieves a userdata value of the given type.
peekUDGeneric :: LuaError e
              => UDTypeGeneric e fn a -> Peeker e a
peekUDGeneric :: forall e fn a. LuaError e => UDTypeGeneric e fn a -> Peeker e a
peekUDGeneric UDTypeGeneric e fn a
ty StackIndex
idx = do
  let name :: Name
name = UDTypeGeneric e fn a -> Name
forall e fn a. UDTypeGeneric e fn a -> Name
udName UDTypeGeneric e fn a
ty
  old <- Name -> (StackIndex -> LuaE e (Maybe a)) -> Peeker e a
forall e a. Name -> (StackIndex -> LuaE e (Maybe a)) -> Peeker e a
reportValueOnFailure Name
name (StackIndex -> Name -> LuaE e (Maybe a)
forall a e. StackIndex -> Name -> LuaE e (Maybe a)
`fromuserdata` Name
name) StackIndex
idx
  -- get caching table and update the Haskell value
  updated <- liftLua (getiuservalue idx 1) >>= \case
    Type
TypeTable -> LuaE e a -> Peek e a
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e a -> Peek e a) -> LuaE e a -> Peek e a
forall a b. (a -> b) -> a -> b
$ do
      LuaE e ()
forall e. LuaE e ()
pushnil
      Map Name (Property e a) -> a -> LuaE e a
forall e a. LuaError e => Map Name (Property e a) -> a -> LuaE e a
setProperties (UDTypeGeneric e fn a -> Map Name (Property e a)
forall e fn a. UDTypeGeneric e fn a -> Map Name (Property e a)
udProperties UDTypeGeneric e fn a
ty) a
old
    Type
_other -> a -> Peek e a
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
old
  liftLua $ pop 1  -- pop caching table
  hookPeekUD (udHooks ty) updated idx

-- | Retrieves object properties from a uservalue table and sets them on
-- the given value. Expects the uservalue table at the top of the stack.
setProperties :: LuaError e => Map Name (Property e a) -> a -> LuaE e a
setProperties :: forall e a. LuaError e => Map Name (Property e a) -> a -> LuaE e a
setProperties Map Name (Property e a)
props a
x = do
  hasNext <- StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
Unsafe.next (CInt -> StackIndex
nth CInt
2)
  let continue a
value = Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1 LuaE e () -> LuaE e a -> LuaE e a
forall a b. LuaE e a -> LuaE e b -> LuaE e b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Name (Property e a) -> a -> LuaE e a
forall e a. LuaError e => Map Name (Property e a) -> a -> LuaE e a
setProperties Map Name (Property e a)
props a
value
  if not hasNext
    then return x
    else ltype (nth 2) >>= \case
      Type
TypeString -> do
        propName <- Peek e Name -> LuaE e Name
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek e Name -> LuaE e Name) -> Peek e Name -> LuaE e Name
forall a b. (a -> b) -> a -> b
$ Peeker e Name
forall e. Peeker e Name
peekName (CInt -> StackIndex
nth CInt
2)
        case Map.lookup propName props >>= propertySet of
          Maybe (StackIndex -> a -> LuaE e a)
Nothing -> a -> LuaE e a
continue a
x
          Just StackIndex -> a -> LuaE e a
setter -> do
            x' <- StackIndex -> a -> LuaE e a
setter StackIndex
top a
x
            continue x'
      Type
_ -> a -> LuaE e a
continue a
x

--
-- Typing
--

-- | Returns documentation for this type.
udDocs :: UDTypeGeneric e fn a
       -> TypeDocs
udDocs :: forall e fn a. UDTypeGeneric e fn a -> TypeDocs
udDocs UDTypeGeneric e fn a
ty = TypeDocs
  { typeDescription :: Text
typeDescription = Text
forall a. Monoid a => a
mempty
  , typeSpec :: TypeSpec
typeSpec = TypeSpec
userdataType
  , typeRegistry :: Maybe Name
typeRegistry = Name -> Maybe Name
forall a. a -> Maybe a
Just (UDTypeGeneric e fn a -> Name
forall e fn a. UDTypeGeneric e fn a -> Name
udName UDTypeGeneric e fn a
ty)
  }

-- | Type specifier for a UDType
udTypeSpec :: UDTypeGeneric e fn a
           -> TypeSpec
udTypeSpec :: forall e fn a. UDTypeGeneric e fn a -> TypeSpec
udTypeSpec = Name -> TypeSpec
NamedType (Name -> TypeSpec)
-> (UDTypeGeneric e fn a -> Name)
-> UDTypeGeneric e fn a
-> TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UDTypeGeneric e fn a -> Name
forall e fn a. UDTypeGeneric e fn a -> Name
udName