{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-|
Module      : HsLua.ObjectOrientation
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
  ( UDType
  , UDTypeWithList (..)
    -- * Defining types
  , deftypeGeneric
  , deftypeGeneric'
    -- ** Methods
  , methodGeneric
    -- ** Properties
  , property
  , property'
  , possibleProperty
  , possibleProperty'
  , readonly
  , readonly'
    -- ** Aliases
  , alias
    -- * Marshaling
  , peekUDGeneric
  , pushUDGeneric
  , initTypeGeneric
    -- * Type docs
  , udDocs
  , udTypeSpec
    -- * Helper types for building
  , Member
  , Property (..)
  , Operation (..)
  , ListSpec
  , 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 Data.Void (Void)
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 UDTypeWithList e fn a itemtype = UDTypeWithList
  { forall e fn a itemtype. UDTypeWithList e fn a itemtype -> Name
udName          :: Name
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> [(Operation, fn)]
udOperations    :: [(Operation, fn)]
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name (Property e a)
udProperties    :: Map Name (Property e a)
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name fn
udMethods       :: Map Name fn
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map AliasIndex Alias
udAliases       :: Map AliasIndex Alias
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
udListSpec      :: Maybe (ListSpec e a itemtype)
  , forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
udFnPusher      :: fn -> LuaE e ()
  }

-- | Pair of pairs, describing how a type can be used as a Lua list. The
-- first pair describes how to push the list items, and how the list is
-- extracted from the type; the second pair contains a method to
-- retrieve list items, and defines how the list is used to create an
-- updated value.
type ListSpec e a itemtype =
  ( (Pusher e itemtype, a -> [itemtype])
  , (Peeker e itemtype, a -> [itemtype] -> a)
  )

-- | 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.
type UDType e fn a = UDTypeWithList e fn a Void

-- | Defines a new type, defining the behavior of objects in 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
               -> UDType e fn a
deftypeGeneric :: forall e fn a.
Pusher e fn
-> Name -> [(Operation, fn)] -> [Member e fn a] -> UDType e fn a
deftypeGeneric Pusher e fn
pushFunction Name
name [(Operation, fn)]
ops [Member e fn a]
members =
  Pusher e fn
-> Name
-> [(Operation, fn)]
-> [Member e fn a]
-> Maybe (ListSpec e a Void)
-> UDTypeWithList e fn a Void
forall e fn a itemtype.
Pusher e fn
-> Name
-> [(Operation, fn)]
-> [Member e fn a]
-> Maybe (ListSpec e a itemtype)
-> UDTypeWithList e fn a itemtype
deftypeGeneric' Pusher e fn
pushFunction Name
name [(Operation, fn)]
ops [Member e fn a]
members Maybe (ListSpec e a Void)
forall a. Maybe a
Nothing

-- | Defines a new type that could also be treated as a list; defines
-- the behavior of objects in 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
                -> Maybe (ListSpec e a itemtype)  -- ^ list access
                -> UDTypeWithList e fn a itemtype
deftypeGeneric' :: forall e fn a itemtype.
Pusher e fn
-> Name
-> [(Operation, fn)]
-> [Member e fn a]
-> Maybe (ListSpec e a itemtype)
-> UDTypeWithList e fn a itemtype
deftypeGeneric' Pusher e fn
pushFunction Name
name [(Operation, fn)]
ops [Member e fn a]
members Maybe (ListSpec e a itemtype)
mbListSpec = UDTypeWithList
  { 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
  , udListSpec :: Maybe (ListSpec e a itemtype)
udListSpec      = Maybe (ListSpec e a itemtype)
mbListSpec
  , 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
      b
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 a -> b -> Possible a
set a
x b
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.
--
-- The @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.
initTypeGeneric :: LuaError e
                => (UDTypeWithList e fn a itemtype -> LuaE e ())
                -> UDTypeWithList e fn a itemtype
                -> LuaE e Name
initTypeGeneric :: forall e fn a itemtype.
LuaError e =>
(UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e Name
initTypeGeneric UDTypeWithList e fn a itemtype -> LuaE e ()
hook UDTypeWithList e fn a itemtype
ty = do
  (UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
(UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e ()
pushUDMetatable UDTypeWithList e fn a itemtype -> LuaE e ()
hook UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Name
forall e fn a itemtype. UDTypeWithList e fn a itemtype -> Name
udName UDTypeWithList e fn a itemtype
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 :: LuaError e
  => (UDTypeWithList e fn a itemtype -> LuaE e ())  -- ^ @hook@
  -> UDTypeWithList e fn a itemtype
  -> LuaE e ()
pushUDMetatable :: forall e fn a itemtype.
LuaError e =>
(UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e ()
pushUDMetatable UDTypeWithList e fn a itemtype -> LuaE e ()
hook UDTypeWithList e fn a itemtype
ty = do
  Bool
created <- Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newudmetatable (UDTypeWithList e fn a itemtype -> Name
forall e fn a itemtype. UDTypeWithList e fn a itemtype -> Name
udName UDTypeWithList e fn a itemtype
ty)
  Bool -> LuaE e () -> LuaE e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
created (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ do
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add (Operation -> Name
metamethodName Operation
Index)    (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction CFunction
hslua_udindex_ptr
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add (Operation -> Name
metamethodName Operation
Newindex) (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction CFunction
hslua_udnewindex_ptr
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add (Operation -> Name
metamethodName Operation
Pairs)    (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ HaskellFunction e -> LuaE e ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction (UDTypeWithList e fn a itemtype -> HaskellFunction e
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e NumResults
pairsFunction UDTypeWithList e fn a itemtype
ty)
    [(Operation, fn)] -> ((Operation, fn) -> LuaE e ()) -> LuaE e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (UDTypeWithList e fn a itemtype -> [(Operation, fn)]
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> [(Operation, fn)]
udOperations UDTypeWithList e fn a itemtype
ty) (((Operation, fn) -> LuaE e ()) -> LuaE e ())
-> ((Operation, fn) -> LuaE e ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \(Operation
op, fn
f) -> do
      Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => 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
$ UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
udFnPusher UDTypeWithList e fn a itemtype
ty fn
f
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add Name
"getters" (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushGetters UDTypeWithList e fn a itemtype
ty
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add Name
"setters" (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushSetters UDTypeWithList e fn a itemtype
ty
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add Name
"methods" (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushMethods UDTypeWithList e fn a itemtype
ty
    Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add Name
"aliases" (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushAliases UDTypeWithList e fn a itemtype
ty
    case UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
udListSpec UDTypeWithList e fn a itemtype
ty of
      Maybe (ListSpec e a itemtype)
Nothing -> () -> LuaE e ()
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ((Pusher e itemtype
pushItem, a -> [itemtype]
_), (Peeker e itemtype, a -> [itemtype] -> a)
_) -> do
        Name -> LuaE e () -> LuaE e ()
forall e. LuaError e => Name -> LuaE e () -> LuaE e ()
add Name
"lazylisteval" (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ HaskellFunction e -> LuaE e ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction (Pusher e itemtype -> HaskellFunction e
forall itemtype e.
LuaError e =>
Pusher e itemtype -> LuaE e NumResults
lazylisteval Pusher e itemtype
pushItem)
    UDTypeWithList e fn a itemtype -> LuaE e ()
hook UDTypeWithList e fn a itemtype
ty
  where
    add :: LuaError e => Name -> LuaE e () -> LuaE e ()
    add :: forall e. LuaError e => 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 => UDTypeWithList e fn a itemtype -> LuaE e ()
pushGetters :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushGetters UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Map Name (Property e a)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name (Property e a)
udProperties UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Peeker e a
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> Peeker e a
peekUDGeneric UDTypeWithList e fn a itemtype
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 => UDTypeWithList e fn a itemtype -> LuaE e ()
pushSetters :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushSetters UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Map Name (Property e a)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name (Property e a)
udProperties UDTypeWithList e fn a itemtype
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 => UDTypeWithList e fn a itemtype -> LuaE e ()
pushMethods :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushMethods UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Map Name fn
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name fn
udMethods UDTypeWithList e fn a itemtype
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
    UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
udFnPusher UDTypeWithList e fn a itemtype
ty fn
fn
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

pushAliases :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e ()
pushAliases :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e ()
pushAliases UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Map AliasIndex Alias
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map AliasIndex Alias
udAliases UDTypeWithList e fn a itemtype
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 :: forall e fn a itemtype. LuaError e
              => UDTypeWithList e fn a itemtype -> LuaE e NumResults
pairsFunction :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> LuaE e NumResults
pairsFunction UDTypeWithList e fn a itemtype
ty = do
  a
obj <- Peek e a -> LuaE e a
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek e a -> LuaE e a) -> Peek e a -> LuaE e a
forall a b. (a -> b) -> a -> b
$ UDTypeWithList e fn a itemtype -> Peeker e a
forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> Peeker e a
peekUDGeneric UDTypeWithList e fn a itemtype
ty (CInt -> StackIndex
nthBottom CInt
1)
  let pushMember :: Member e fn a -> LuaE e NumResults
pushMember = \case
        MemberProperty Name
name Property e a
prop -> do
          Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
          NumResults
getresults <- Property e a -> a -> LuaE e NumResults
forall e a. Property e a -> a -> LuaE e NumResults
propertyGet Property e a
prop a
obj
          if NumResults
getresults NumResults -> NumResults -> Bool
forall a. Eq a => a -> a -> Bool
== NumResults
0
            then NumResults
0 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
<$ Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1  -- property is absent, don't push anything
            else NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return (NumResults -> LuaE e NumResults)
-> NumResults -> LuaE e NumResults
forall a b. (a -> b) -> a -> b
$ NumResults
getresults NumResults -> NumResults -> NumResults
forall a. Num a => a -> a -> a
+ NumResults
1
        MemberMethod Name
name fn
f -> do
          Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
          UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> fn -> LuaE e ()
udFnPusher UDTypeWithList e fn a itemtype
ty fn
f
          NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
2
        MemberAlias{} -> String -> LuaE e NumResults
forall a. String -> LuaE e a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"aliases are not full properties"
  (Member e fn a -> LuaE e NumResults)
-> [Member e fn a] -> LuaE e NumResults
forall a e.
LuaError e =>
(a -> LuaE e NumResults) -> [a] -> LuaE e NumResults
pushIterator Member e fn a -> LuaE e NumResults
pushMember ([Member e fn a] -> LuaE e NumResults)
-> [Member e fn a] -> LuaE e NumResults
forall a b. (a -> b) -> a -> b
$
    ((Name, Property e a) -> Member e fn a)
-> [(Name, Property e a)] -> [Member e fn a]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Property e a -> Member e fn a)
-> (Name, Property e a) -> Member e fn a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Property e a -> Member e fn a
forall e fn a. Name -> Property e a -> Member e fn a
MemberProperty) (Map Name (Property e a) -> [(Name, Property e a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (UDTypeWithList e fn a itemtype -> Map Name (Property e a)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name (Property e a)
udProperties UDTypeWithList e fn a itemtype
ty)) [Member e fn a] -> [Member e fn a] -> [Member e fn a]
forall a. [a] -> [a] -> [a]
++
    ((Name, fn) -> Member e fn a) -> [(Name, fn)] -> [Member e fn a]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> fn -> Member e fn a) -> (Name, fn) -> Member e fn a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> fn -> Member e fn a
forall e fn a. Name -> fn -> Member e fn a
MemberMethod) (Map Name fn -> [(Name, fn)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (UDTypeWithList e fn a itemtype -> Map Name fn
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name fn
udMethods UDTypeWithList e fn a itemtype
ty))

-- | Evaluate part of a lazy list. Takes the following arguments, in
-- this order:
--
-- 1. userdata wrapping the unevalled part of the lazy list
-- 2. index of the last evaluated element
-- 3. index of the requested element
-- 4. the caching table
lazylisteval :: forall itemtype e. LuaError e
             => Pusher e itemtype -> LuaE e NumResults
lazylisteval :: forall itemtype e.
LuaError e =>
Pusher e itemtype -> LuaE e NumResults
lazylisteval Pusher e itemtype
pushItem = do
  Maybe [itemtype]
munevaled <- forall a e. StackIndex -> Name -> LuaE e (Maybe a)
fromuserdata @[itemtype] (CInt -> StackIndex
nthBottom CInt
1) Name
lazyListStateName
  Maybe Integer
mcurindex <- StackIndex -> LuaE e (Maybe Integer)
forall e. StackIndex -> LuaE e (Maybe Integer)
tointeger (CInt -> StackIndex
nthBottom CInt
2)
  Maybe Integer
mnewindex <- StackIndex -> LuaE e (Maybe Integer)
forall e. StackIndex -> LuaE e (Maybe Integer)
tointeger (CInt -> StackIndex
nthBottom CInt
3)
  case (Maybe [itemtype]
munevaled, Maybe Integer
mcurindex, Maybe Integer
mnewindex) of
    (Just [itemtype]
unevaled, Just Integer
curindex, Just Integer
newindex) -> do
      let numElems :: Int
numElems = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Integer
newindex Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
curindex) Integer
0
          ([itemtype]
as, [itemtype]
rest) = Int -> [itemtype] -> ([itemtype], [itemtype])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
numElems [itemtype]
unevaled
      if [itemtype] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [itemtype]
rest
        then do
          -- no more elements in list; unset variable
          Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
"__lazylistindex"
          Pusher e Bool
forall e. Pusher e Bool
pushBool Bool
False
          StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nthBottom CInt
4)
        else do
          -- put back remaining unevalled list
          LuaE e Bool -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e Bool -> LuaE e ()) -> LuaE e Bool -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ forall a e. StackIndex -> Name -> a -> LuaE e Bool
putuserdata @[itemtype] (CInt -> StackIndex
nthBottom CInt
1) Name
lazyListStateName [itemtype]
rest
          Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
"__lazylistindex"
          Integer -> LuaE e ()
forall e. Integer -> LuaE e ()
pushinteger (Integer
curindex Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([itemtype] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [itemtype]
as))
          StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nthBottom CInt
4)
      -- push evaluated elements
      [(Integer, itemtype)]
-> ((Integer, itemtype) -> LuaE e ()) -> LuaE e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Integer] -> [itemtype] -> [(Integer, itemtype)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Integer
curindex Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)..] [itemtype]
as) (((Integer, itemtype) -> LuaE e ()) -> LuaE e ())
-> ((Integer, itemtype) -> LuaE e ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \(Integer
i, itemtype
a) -> do
        Pusher e itemtype
pushItem itemtype
a
        StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
rawseti (CInt -> StackIndex
nthBottom CInt
4) Integer
i
      NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> NumResults
NumResults CInt
0)
    (Maybe [itemtype], Maybe Integer, Maybe Integer)
_ -> NumResults -> LuaE e NumResults
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> NumResults
NumResults CInt
0)

-- | Name of the metatable used for unevaluated lazy list rema
lazyListStateName :: Name
lazyListStateName :: Name
lazyListStateName = Name
"HsLua unevalled lazy list"

-- | Pushes a userdata value of the given type.
pushUDGeneric :: LuaError e
  => (UDTypeWithList e fn a itemtype -> LuaE e ()) -- ^ push docs
  -> UDTypeWithList e fn a itemtype                -- ^ userdata type
  -> a                                             -- ^ value to push
  -> LuaE e ()
pushUDGeneric :: forall e fn a itemtype.
LuaError e =>
(UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> a -> LuaE e ()
pushUDGeneric UDTypeWithList e fn a itemtype -> LuaE e ()
pushDocs UDTypeWithList e fn a itemtype
ty a
x = do
  a -> Int -> LuaE e ()
forall a e. a -> Int -> LuaE e ()
newhsuserdatauv a
x Int
1
  (UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e ()
forall e fn a itemtype.
LuaError e =>
(UDTypeWithList e fn a itemtype -> LuaE e ())
-> UDTypeWithList e fn a itemtype -> LuaE e ()
pushUDMetatable UDTypeWithList e fn a itemtype -> LuaE e ()
pushDocs UDTypeWithList e fn a itemtype
ty
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
2)
  -- add list as value in caching table
  case UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
udListSpec UDTypeWithList e fn a itemtype
ty of
    Maybe (ListSpec e a itemtype)
Nothing -> () -> LuaE e ()
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ((Pusher e itemtype
_, a -> [itemtype]
toList), (Peeker e itemtype, a -> [itemtype] -> a)
_) -> do
      LuaE e ()
forall e. LuaE e ()
newtable
      Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
"__lazylist"
      [itemtype] -> Int -> LuaE e ()
forall a e. a -> Int -> LuaE e ()
newhsuserdatauv (a -> [itemtype]
toList a
x) Int
1
      LuaE e Bool -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newudmetatable Name
lazyListStateName)
      StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
2)
      StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)
      LuaE e Bool -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StackIndex -> Int -> LuaE e Bool
forall e. StackIndex -> Int -> LuaE e Bool
setiuservalue (CInt -> StackIndex
nth CInt
2) Int
1)

-- | Retrieves a userdata value of the given type.
peekUDGeneric :: LuaError e => UDTypeWithList e fn a itemtype -> Peeker e a
peekUDGeneric :: forall e fn a itemtype.
LuaError e =>
UDTypeWithList e fn a itemtype -> Peeker e a
peekUDGeneric UDTypeWithList e fn a itemtype
ty StackIndex
idx = do
  let name :: Name
name = UDTypeWithList e fn a itemtype -> Name
forall e fn a itemtype. UDTypeWithList e fn a itemtype -> Name
udName UDTypeWithList e fn a itemtype
ty
  a
x <- 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
  (Peek e a -> LuaE e () -> Peek e a
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1) (Peek e a -> Peek e a) -> Peek e a -> Peek e a
forall a b. (a -> b) -> a -> b
$ LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Int -> LuaE e Type
forall e. StackIndex -> Int -> LuaE e Type
getiuservalue StackIndex
idx Int
1) Peek e Type -> (Type -> Peek e a) -> Peek e a
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Type
TypeTable -> do
      -- set list
      a
xWithList <- (a -> Peek e a)
-> (ListSpec e a itemtype -> a -> Peek e a)
-> Maybe (ListSpec e a itemtype)
-> a
-> Peek e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> Peek e a
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ListSpec e a itemtype -> a -> Peek e a
forall itemtype e a.
LuaError e =>
ListSpec e a itemtype -> a -> Peek e a
setList (UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Maybe (ListSpec e a itemtype)
udListSpec UDTypeWithList e fn a itemtype
ty) a
x
      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 (UDTypeWithList e fn a itemtype -> Map Name (Property e a)
forall e fn a itemtype.
UDTypeWithList e fn a itemtype -> Map Name (Property e a)
udProperties UDTypeWithList e fn a itemtype
ty) a
xWithList
    Type
_ -> a -> Peek e a
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | 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
  Bool
hasNext <- StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
Unsafe.next (CInt -> StackIndex
nth CInt
2)
  if Bool -> Bool
not Bool
hasNext
    then a -> LuaE e a
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    else StackIndex -> LuaE e Type
forall e. StackIndex -> LuaE e Type
ltype (CInt -> StackIndex
nth CInt
2) LuaE e Type -> (Type -> LuaE e a) -> LuaE e a
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
>>= \case
      Type
TypeString -> do
        Name
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 Name -> Map Name (Property e a) -> Maybe (Property e a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
propName Map Name (Property e a)
props Maybe (Property e a)
-> (Property e a -> Maybe (StackIndex -> a -> LuaE e a))
-> Maybe (StackIndex -> a -> LuaE e a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Property e a -> Maybe (StackIndex -> a -> LuaE e a)
forall e a. Property e a -> Maybe (StackIndex -> a -> LuaE e a)
propertySet of
          Maybe (StackIndex -> a -> LuaE e a)
Nothing -> 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
x
          Just StackIndex -> a -> LuaE e a
setter -> do
            a
x' <- StackIndex -> a -> LuaE e a
setter StackIndex
top a
x
            Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
            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
x'
      Type
_ -> a
x a -> LuaE e () -> LuaE e a
forall a b. a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1

-- | Gets a list from a uservalue table and sets it on the given value.
-- Expects the uservalue (i.e., caching) table to be at the top of the
-- stack.
setList :: forall itemtype e a. LuaError e
        => ListSpec e a itemtype -> a
        -> Peek e a
setList :: forall itemtype e a.
LuaError e =>
ListSpec e a itemtype -> a -> Peek e a
setList ((Pusher e itemtype, a -> [itemtype])
_pushspec, (Peeker e itemtype
peekItem, a -> [itemtype] -> a
updateList)) a
x = (a
x a -> [itemtype] -> a
`updateList`) ([itemtype] -> a) -> Peek e [itemtype] -> Peek e a
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> do
  LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Name -> LuaE e Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
top Name
"__lazylistindex") Peek e Type -> (Type -> Peek e [itemtype]) -> Peek e [itemtype]
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Type
TypeBoolean -> do
      -- list had been fully evaluated
      LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> LuaE e () -> Peek e ()
forall a b. (a -> b) -> a -> b
$ Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
      Peeker e itemtype -> Peeker e [itemtype]
forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList Peeker e itemtype
peekItem StackIndex
top
    Type
_ -> do
      let getLazyList :: Peek e [itemtype]
getLazyList = do
            LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Name -> LuaE e Type
forall e. LuaError e => StackIndex -> Name -> LuaE e Type
getfield StackIndex
top Name
"__lazylist") Peek e Type -> (Type -> Peek e ()) -> Peek e ()
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Type
TypeUserdata -> () -> Peek e ()
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Type
_ -> ByteString -> Peek e ()
forall a e. ByteString -> Peek e a
failPeek ByteString
"unevaled items of lazy list cannot be peeked"
            (Peek e [itemtype] -> LuaE e () -> Peek e [itemtype]
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1) (Peek e [itemtype] -> Peek e [itemtype])
-> Peek e [itemtype] -> Peek e [itemtype]
forall a b. (a -> b) -> a -> b
$ Name
-> (StackIndex -> LuaE e (Maybe [itemtype])) -> Peeker e [itemtype]
forall e a. Name -> (StackIndex -> LuaE e (Maybe a)) -> Peeker e a
reportValueOnFailure
              Name
lazyListStateName
              (\StackIndex
idx -> forall a e. StackIndex -> Name -> LuaE e (Maybe a)
fromuserdata @[itemtype] StackIndex
idx Name
lazyListStateName)
              StackIndex
top
      Maybe Integer
mlastIndex <- LuaE e (Maybe Integer) -> Peek e (Maybe Integer)
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> LuaE e (Maybe Integer)
forall e. StackIndex -> LuaE e (Maybe Integer)
tointeger StackIndex
top LuaE e (Maybe Integer) -> LuaE e () -> LuaE e (Maybe Integer)
forall a b. LuaE e a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1)
      let itemsAfter :: Integer -> Peek e [itemtype]
itemsAfter = case Maybe Integer
mlastIndex of
            Maybe Integer
Nothing -> Peek e [itemtype] -> Integer -> Peek e [itemtype]
forall a b. a -> b -> a
const Peek e [itemtype]
getLazyList
            Just Integer
lastIndex -> \Integer
i ->
              if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
lastIndex
              then LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Integer -> LuaE e Type
forall e. LuaError e => StackIndex -> Integer -> LuaE e Type
rawgeti StackIndex
top Integer
i) Peek e Type -> (Type -> Peek e [itemtype]) -> Peek e [itemtype]
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Type
TypeNil -> [] [itemtype] -> Peek e () -> Peek e [itemtype]
forall a b. a -> Peek e b -> Peek e a
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 (Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1)
                Type
_ -> do
                  itemtype
y <- Peeker e itemtype
peekItem StackIndex
top Peek e itemtype -> LuaE e () -> Peek e itemtype
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
                  (itemtype
yitemtype -> [itemtype] -> [itemtype]
forall a. a -> [a] -> [a]
:) ([itemtype] -> [itemtype])
-> Peek e [itemtype] -> Peek e [itemtype]
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Integer -> Peek e [itemtype]
itemsAfter (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
              else Peek e [itemtype]
getLazyList
      Integer -> Peek e [itemtype]
itemsAfter Integer
1

--
-- Typing
--

-- | Returns documentation for this type.
udDocs :: UDTypeWithList e fn a itemtype
       -> TypeDocs
udDocs :: forall e fn a itemtype. UDTypeWithList e fn a itemtype -> TypeDocs
udDocs UDTypeWithList e fn a itemtype
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 (UDTypeWithList e fn a itemtype -> Name
forall e fn a itemtype. UDTypeWithList e fn a itemtype -> Name
udName UDTypeWithList e fn a itemtype
ty)
  }

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