{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module HsLua.ObjectOrientation.ListType
( UDTypeWithList
, ListSpec
, listExtension
) where
import Control.Monad ((<$!>), forM_, void)
import Foreign.Ptr (FunPtr)
import HsLua.Core as Lua
import HsLua.Marshalling
import HsLua.ObjectOrientation.Generic
import HsLua.ObjectOrientation.Operation (metamethodName)
type UDTypeWithList e fn a itemtype =
UDTypeGeneric e fn a
{-# DEPRECATED UDTypeWithList "Use UDTypeGeneric instead" #-}
type ListSpec e a itemtype =
( (Pusher e itemtype, a -> [itemtype])
, (Peeker e itemtype, a -> [itemtype] -> a)
)
listExtension
:: LuaError e
=> ListSpec e a itemtype
-> UDTypeHooks e fn a
listExtension :: forall e a itemtype fn.
LuaError e =>
ListSpec e a itemtype -> UDTypeHooks e fn a
listExtension ((Pusher e itemtype
pushItem, a -> [itemtype]
toList), (Peeker e itemtype
peekItem, a -> [itemtype] -> a
updateList)) =
UDTypeHooks
{ hookMetatableSetup :: LuaE e ()
hookMetatableSetup = do
Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
"lazylisteval"
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)
StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)
Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName (Operation -> Name
metamethodName Operation
Index)
CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction CFunction
hslua_list_udindex_ptr
StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)
Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName (Operation -> Name
metamethodName Operation
Newindex)
CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction CFunction
hslua_list_udnewindex_ptr
StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)
, hookPeekUD :: a -> StackIndex -> Peek e a
hookPeekUD = \a
x 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 -> Peeker e itemtype -> (a -> [itemtype] -> a) -> a -> Peek e a
forall itemtype a e.
LuaError e =>
Peeker e itemtype -> (a -> [itemtype] -> a) -> a -> Peek e a
setList Peeker e itemtype
peekItem a -> [itemtype] -> a
updateList a
x
Type
_other -> a -> Peek e a
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
, hookPushUD :: a -> LuaE e ()
hookPushUD = \a
x -> 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)
, hookUservalues :: Int
hookUservalues = Int
1
}
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
munevaled <- forall a e. StackIndex -> Name -> LuaE e (Maybe a)
fromuserdata @[itemtype] (CInt -> StackIndex
nthBottom CInt
1) Name
lazyListStateName
mcurindex <- tointeger (nthBottom 2)
mnewindex <- tointeger (nthBottom 3)
case (munevaled, mcurindex, 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
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
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)
[(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)
lazyListStateName :: Name
lazyListStateName :: Name
lazyListStateName = Name
"HsLua unevalled lazy list"
setList :: forall itemtype a e. LuaError e
=> Peeker e itemtype
-> (a -> [itemtype] -> a)
-> a
-> Peek e a
setList :: forall itemtype a e.
LuaError e =>
Peeker e itemtype -> (a -> [itemtype] -> a) -> a -> Peek e a
setList 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
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
otherType -> do
tyname <- LuaE e ByteString -> Peek e ByteString
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e ByteString -> Peek e ByteString)
-> LuaE e ByteString -> Peek e ByteString
forall a b. (a -> b) -> a -> b
$ Type -> LuaE e ByteString
forall e. Type -> LuaE e ByteString
typename Type
otherType
failPeek $
"unevaled items of lazy list cannot be peeked: got " <>
tyname
(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
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 = 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
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
(y:) <$!> itemsAfter (i + 1)
else Peek e [itemtype]
getLazyList
itemsAfter 1
foreign import ccall "hslobj.c &hslua_list_udindex"
hslua_list_udindex_ptr :: FunPtr (State -> IO NumResults)
foreign import ccall "hslobj.c &hslua_list_udnewindex"
hslua_list_udnewindex_ptr :: FunPtr (State -> IO NumResults)