{-# 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)

-- | Userdata type that (also) behaves like a list.
type UDTypeWithList e fn a itemtype =
  UDTypeGeneric e fn a
{-# DEPRECATED UDTypeWithList "Use UDTypeGeneric instead" #-}

-- | 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)
  )

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
      -- Add a function to evaluate the necessary parts of a lazy list.
      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)
      -- Use different field getter
      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)
      -- Use different field setter
      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
      -- Add a field containing the thunk with the unevaluated part of
      -- the lazy list.
      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
  }


-- | 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
  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
          -- 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"

-- | 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 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
      -- 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
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


-- | Gets a new value in the userdata caching table via a getter
-- functions; this function differs from the normal getter in that it
-- treats numerical values as list indices.
foreign import ccall "hslobj.c &hslua_list_udindex"
  hslua_list_udindex_ptr :: FunPtr (State -> IO NumResults)

-- | Sets a new value in the userdata caching table via a setter
-- functions; this function differs from the normal setter in that it
-- treats numerical values as list indices.
foreign import ccall "hslobj.c &hslua_list_udnewindex"
  hslua_list_udnewindex_ptr :: FunPtr (State -> IO NumResults)