{-# 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
  { udName          :: Name
  , udOperations    :: [(Operation, fn)]
  , udProperties    :: Map Name (Property e a)
  , udMethods       :: Map Name fn
  , udAliases       :: Map AliasIndex Alias
  , udListSpec      :: Maybe (ListSpec e a itemtype)
  , 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 pushFunction name ops members =
  deftypeGeneric' pushFunction name ops members 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' pushFunction name ops members mbListSpec = UDTypeWithList
  { udName          = name
  , udOperations    = ops
  , udProperties    = Map.fromList $ mapMaybe mbproperties members
  , udMethods       = Map.fromList $ mapMaybe mbmethods members
  , udAliases       = Map.fromList $ mapMaybe mbaliases members
  , udListSpec      = mbListSpec
  , udFnPusher      = pushFunction
  }
  where
    mbproperties = \case
      MemberProperty n p -> Just (n, p)
      _ -> Nothing
    mbmethods = \case
      MemberMethod n m -> Just (n, m)
      _ -> Nothing
    mbaliases = \case
      MemberAlias n a -> Just (n, a)
      _ -> Nothing

-- | A read- and writable property on a UD object.
data Property e a = Property
  { propertyGet :: a -> LuaE e NumResults
  , propertySet :: Maybe (StackIndex -> a -> LuaE e a)
  , propertyDescription :: Text
  , 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 (Eq, Ord)

instance IsString AliasIndex where
  fromString = StringIndex . 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 = 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' name typespec desc (push, get) (peek, set) =
  possibleProperty' name typespec desc
    (push, Actual . get)
    (peek, \a b -> Actual (set a 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 name desc (push, get) (peek, set) =
  possibleProperty name desc
    (push, Actual . get)
    (peek, \a b -> Actual (set a 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 name = possibleProperty' name 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' name typespec desc (push, get) (peek, set) =
  MemberProperty name $
  Property
  { propertyGet = \x -> do
      case get x of
        Actual y -> NumResults 1 <$ push y
        Absent   -> return (NumResults 0)
  , propertySet = Just $ \idx x -> do
      value  <- forcePeek $ peek idx
      case set x value of
        Actual y -> return y
        Absent   -> failLua $ "Trying to set unavailable property "
                            <> Utf8.toString (fromName name)
                            <> "."
  , propertyType = typespec
  , propertyDescription = 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' name typespec desc (push, get) = MemberProperty name $
  Property
  { propertyGet = \x -> do
      push $ get x
      return (NumResults 1)
  , propertySet = Nothing
  , propertyType = typespec
  , propertyDescription = 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 name = readonly' name 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 name _desc = MemberAlias 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 hook ty = do
  pushUDMetatable hook ty
  pop 1
  return (udName 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 hook ty = do
  created <- newudmetatable (udName 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) $ \(op, f) -> do
      add (metamethodName op) $ udFnPusher ty f
    add "getters" $ pushGetters ty
    add "setters" $ pushSetters ty
    add "methods" $ pushMethods ty
    add "aliases" $ pushAliases ty
    case udListSpec ty of
      Nothing -> pure ()
      Just ((pushItem, _), _) -> do
        add "lazylisteval" $ pushHaskellFunction (lazylisteval pushItem)
    hook ty
  where
    add :: LuaError e => Name -> LuaE e () -> LuaE e ()
    add name op = do
      pushName name
      op
      rawset (nth 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 ty = do
  newtable
  void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do
    pushName name
    pushHaskellFunction $ forcePeek (peekUDGeneric ty 1) >>= propertyGet prop
    rawset (nth 3)

-- | Pushes the metatable's @setters@ field table.
pushSetters :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e ()
pushSetters ty = do
  newtable
  void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do
    pushName name
    pushcfunction $ case propertySet prop of
      Just _  -> hslua_udsetter_ptr
      Nothing -> hslua_udreadonly_ptr
    rawset (nth 3)

-- | Pushes the metatable's @methods@ field table.
pushMethods :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e ()
pushMethods ty = do
  newtable
  void $ flip Map.traverseWithKey (udMethods ty) $ \name fn -> do
    pushName name
    udFnPusher ty fn
    rawset (nth 3)

pushAliases :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e ()
pushAliases ty = do
  newtable
  void $ flip Map.traverseWithKey (udAliases ty) $ \name propSeq -> do
    pushAliasIndex name
    pushList pushAliasIndex propSeq
    rawset (nth 3)

pushAliasIndex :: Pusher e AliasIndex
pushAliasIndex = \case
  StringIndex name -> pushName name
  IntegerIndex n   -> pushIntegral 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 ty = do
  obj <- forcePeek $ peekUDGeneric ty (nthBottom 1)
  let pushMember = \case
        MemberProperty name prop -> do
          pushName name
          getresults <- propertyGet prop obj
          if getresults == 0
            then 0 <$ pop 1  -- property is absent, don't push anything
            else return $ getresults + 1
        MemberMethod name f -> do
          pushName name
          udFnPusher ty f
          return 2
        MemberAlias{} -> fail "aliases are not full properties"
  pushIterator pushMember $
    map (uncurry MemberProperty) (Map.toAscList (udProperties ty)) ++
    map (uncurry MemberMethod) (Map.toAscList (udMethods 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 pushItem = do
  munevaled <- fromuserdata @[itemtype] (nthBottom 1) lazyListStateName
  mcurindex <- tointeger (nthBottom 2)
  mnewindex <- tointeger (nthBottom 3)
  case (munevaled, mcurindex, mnewindex) of
    (Just unevaled, Just curindex, Just newindex) -> do
      let numElems = fromIntegral $ max (newindex - curindex) 0
          (as, rest) = splitAt numElems unevaled
      if null rest
        then do
          -- no more elements in list; unset variable
          pushName "__lazylistindex"
          pushBool False
          rawset (nthBottom 4)
        else do
          -- put back remaining unevalled list
          void $ putuserdata @[itemtype] (nthBottom 1) lazyListStateName rest
          pushName "__lazylistindex"
          pushinteger (curindex + fromIntegral (length as))
          rawset (nthBottom 4)
      -- push evaluated elements
      forM_ (zip [(curindex + 1)..] as) $ \(i, a) -> do
        pushItem a
        rawseti (nthBottom 4) i
      return (NumResults 0)
    _ -> pure (NumResults 0)

-- | Name of the metatable used for unevaluated lazy list rema
lazyListStateName :: Name
lazyListStateName = "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 pushDocs ty x = do
  newhsuserdatauv x 1
  pushUDMetatable pushDocs ty
  setmetatable (nth 2)
  -- add list as value in caching table
  case udListSpec ty of
    Nothing -> pure ()
    Just ((_, toList), _) -> do
      newtable
      pushName "__lazylist"
      newhsuserdatauv (toList x) 1
      void (newudmetatable lazyListStateName)
      setmetatable (nth 2)
      rawset (nth 3)
      void (setiuservalue (nth 2) 1)

-- | Retrieves a userdata value of the given type.
peekUDGeneric :: LuaError e => UDTypeWithList e fn a itemtype -> Peeker e a
peekUDGeneric ty idx = do
  let name = udName ty
  x <- reportValueOnFailure name (`fromuserdata` name) idx
  (`lastly` pop 1) $ liftLua (getiuservalue idx 1) >>= \case
    TypeTable -> do
      -- set list
      xWithList <- maybe pure setList (udListSpec ty) x
      liftLua $ do
        pushnil
        setProperties (udProperties ty) xWithList
    _ -> return 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 props x = do
  hasNext <- Unsafe.next (nth 2)
  if not hasNext
    then return x
    else ltype (nth 2) >>= \case
      TypeString -> do
        propName <- forcePeek $ peekName (nth 2)
        case Map.lookup propName props >>= propertySet of
          Nothing -> pop 1 *> setProperties props x
          Just setter -> do
            x' <- setter top x
            pop 1
            setProperties props x'
      _ -> x <$ pop 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 (_pushspec, (peekItem, updateList)) x = (x `updateList`) <$!> do
  liftLua (getfield top "__lazylistindex") >>= \case
    TypeBoolean -> do
      -- list had been fully evaluated
      liftLua $ pop 1
      peekList peekItem top
    _ -> do
      let getLazyList = do
            liftLua (getfield top "__lazylist") >>= \case
              TypeUserdata -> pure ()
              _ -> failPeek "unevaled items of lazy list cannot be peeked"
            (`lastly` pop 1) $ reportValueOnFailure
              lazyListStateName
              (\idx -> fromuserdata @[itemtype] idx lazyListStateName)
              top
      mlastIndex <- liftLua (tointeger top <* pop 1)
      let itemsAfter = case mlastIndex of
            Nothing -> const getLazyList
            Just lastIndex -> \i ->
              if i <= lastIndex
              then liftLua (rawgeti top i) >>= \case
                TypeNil -> [] <$ liftLua (pop 1)
                _ -> do
                  y <- peekItem top `lastly` pop 1
                  (y:) <$!> itemsAfter (i + 1)
              else getLazyList
      itemsAfter 1

--
-- Typing
--

-- | Returns documentation for this type.
udDocs :: UDTypeWithList e fn a itemtype
       -> TypeDocs
udDocs ty = TypeDocs
  { typeDescription = mempty
  , typeSpec = userdataType
  , typeRegistry = Just (udName ty)
  }

-- | Type specifier for a UDType
udTypeSpec :: UDTypeWithList e fn a itemtype
           -> TypeSpec
udTypeSpec = NamedType . udName