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

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

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

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

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

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

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

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

  , hookPushUD :: a -> LuaE e ()
    -- ^ Push extra data
  }

-- | No extension.
emptyHooks :: UDTypeHooks e fn a
emptyHooks = UDTypeHooks
  { hookMetatableSetup = return ()

  , hookPeekUD = \x _idx -> return x

  , hookPushUD = \_x -> return ()

  , hookUservalues = 1
  }

-- | Defines a new "Lua type" and sets the behavior of the Lua object
-- instances. It's possible to pass custom type extensions, which modify
-- the default object behavior. Furthermore, the /function pusher/
-- parameter controls how functions are marshaled to Lua.
--
-- Note that the type name must be unique.
deftypeGeneric' :: Pusher e fn          -- ^ function pusher
                -> Name                 -- ^ type name
                -> [(Operation, fn)]    -- ^ operations
                -> [Member e fn a]      -- ^ methods
                -> UDTypeHooks e fn a   -- ^ behavior modifying hooks
                -> UDTypeGeneric e fn a
deftypeGeneric' pushFunction name ops members extension = UDType
  { udName          = name
  , udOperations    = ops
  , udProperties    = Map.fromList $ mapMaybe mbproperties members
  , udMethods       = Map.fromList $ mapMaybe mbmethods members
  , udAliases       = Map.fromList $ mapMaybe mbaliases members
  , udHooks         = extension
  , 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.
initType :: LuaError e
         => UDTypeGeneric e fn a
         -> LuaE e Name
initType ty = do
  pushUDMetatable 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
  :: forall e fn a. LuaError e
  => UDTypeGeneric e fn a
  -> LuaE e ()
pushUDMetatable 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
    hookMetatableSetup (udHooks ty)
  where
    add :: 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
  => UDTypeGeneric e fn a -> 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 => UDTypeGeneric e fn a -> 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 => UDTypeGeneric e fn a -> 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 => UDTypeGeneric e fn a -> 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
  :: LuaError err
  => UDTypeGeneric err fn a -> LuaE err 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))

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

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

-- | Retrieves object properties from a uservalue table and sets them on
-- the given value. Expects the uservalue table at the top of the stack.
setProperties :: LuaError e => Map Name (Property e a) -> a -> LuaE e a
setProperties props x = do
  hasNext <- Unsafe.next (nth 2)
  let continue value = pop 1 *> setProperties props value
  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 -> continue x
          Just setter -> do
            x' <- setter top x
            continue x'
      _ -> continue x

--
-- Typing
--

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