{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}
{-|
Module      : HsLua.ObjectOrientationTests
Copyright   : © 2007–2012 Gracjan Polak;
              © 2012–2016 Ömer Sinan Ağacan;
              © 2017-2024 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>
Stability   : beta
Portability : non-portable (depends on GHC)

Test that conversions from and to the Lua stack are isomorphisms.
-}
module HsLua.ObjectOrientationTests (tests) where

import HsLua.Core
import HsLua.ObjectOrientation
import HsLua.Marshalling
import HsLua.Typing
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HsLua ((=:), shouldBeResultOf, shouldBeErrorMessageOf)
import qualified Data.ByteString.Char8 as Char8

-- | Tests for HsLua object orientation.
tests :: TestTree
tests = testGroup "Object Orientation"
  [ testGroup "Sample product type"
    [ "tostring" =:
      "Foo 7 \"seven\"" `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 7 "seven"
        setglobal "foo"
        _ <- dostring "return tostring(foo)"
        forcePeek $ peekText top

    , "show" =:
      "Foo 5 \"five\"" `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 5 "five"
        setglobal "foo"
        _ <- dostring "return foo:show()"
        forcePeek $ peekText top

    , "peek" =:
      Foo 37 "ananas" `shouldBeResultOf` do
        pushUD typeFoo $ Foo 37 "ananas"
        forcePeek $ peekUDGeneric typeFoo top

    , "unknown properties have value `nil`" =:
      TypeNil `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo (-1) "a"
        setglobal "foo"
        dostring "return foo.does_not_exist" >>= \case
          OK -> ltype top
          _ -> throwErrorAsException

    , "get number" =:
      (-1) `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo (-1) "a"
        setglobal "foo"
        dostring "return foo.num" >>= \case
          OK -> forcePeek $ peekIntegral @Int top
          _ -> throwErrorAsException

    , "get number twice" =:
      8 `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 4 "d"
        setglobal "foo"
        dostring "return foo.num + foo.num" >>= \case
          OK -> forcePeek $ peekIntegral @Int top
          _ -> throwErrorAsException

    , "modify number" =:
      Foo (-1) "a" `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 1 "a"
        setglobal "foo"
        OK <- dostring "foo.num = -1"
        TypeUserdata <- getglobal "foo"
        forcePeek $ peekUDGeneric typeFoo top

    , "get string" =:
      "lint" `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 0 "lint"
        setglobal "foo"
        dostring "return foo.str" >>= \case
          OK -> forcePeek $ peekText top
          _ -> throwErrorAsException

    , "cannot change readonly string" =:
      "'str' is a read-only property." `shouldBeErrorMessageOf` do
        openlibs
        pushUD typeFoo $ Foo 2 "b"
        setglobal "foo"
        ErrRun <- dostring "foo.str = 'c'"
        throwErrorAsException :: Lua ()

    , "Can peek after getting read-only property" =:
      Foo 144 "gros" `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 144 "gros"
        setglobal "foo"
        OK <- dostring "bar = foo.str"
        _ <- getglobal "foo"
        forcePeek $ peekUDGeneric typeFoo top

    , "cannot change unknown property" =:
      "Cannot set unknown property." `shouldBeErrorMessageOf` do
        openlibs
        pushUD typeFoo $ Foo 11 "eleven"
        setglobal "foo"
        ErrRun <- dostring "foo.does_not_exist = nil"
        throwErrorAsException :: Lua ()

    , "pairs iterates over properties" =:
      ["num", "5", "str", "echo", "show", "function"] `shouldBeResultOf` do
        openlibs
        pushUD typeFoo $ Foo 5 "echo"
        setglobal "echo"
        OK <- dostring $ Char8.unlines
          [ "local result = {}"
          , "for k, v in pairs(echo) do"
          , "  table.insert(result, k)"
          , "  table.insert("
          , "    result,"
          , "    type(v) == 'function' and 'function' or tostring(v)"
          , "  )"
          , "end"
          , "return result"
          ]
        forcePeek $ peekList peekText top

    , "absent properties are not included in `pairs`" =:
      [("num", "number"), ("str", "string"), ("show", "function")]
      `shouldBeResultOf` do
        openlibs
        pushUD typeQux $ Quux 1 "a"
        setglobal "a"
        OK <- dostring $ Char8.unlines
          [ "local result = {}"
          , "for k, v in pairs(a) do result[#result+1] = {k, type(v)} end"
          , "return result"
          ]
        forcePeek $ peekList (peekPair peekText peekText) top
    ]

  , testGroup "Bar type"
    [ "Modifying a table modifies the object" =:
      Bar [7, 8] `shouldBeResultOf` do
        openlibs
        pushUD typeBar $ Bar [7]
        setglobal "bar"
        OK <- dostring "table.insert(bar.nums, 8)"
        _ <- getglobal "bar"
        forcePeek $ peekUDGeneric typeBar top

    , "Use integer index in alias" =:
      42 `shouldBeResultOf` do
        openlibs
        pushUD typeBar $ Bar [42, 5, 23]
        setglobal "bar"
        OK <- dostring "return bar.first"
        forcePeek $ peekIntegral @Int top
    ]

  , testGroup "initType"
    [ "type table is added to the registry" =:
      TypeTable `shouldBeResultOf` do
        openlibs
        name <- initTypeGeneric (\_ -> pure ()) typeBar
        getfield registryindex name

    , "type table is not in registry when uninitialized" =:
      TypeNil `shouldBeResultOf` do
        openlibs
        getfield registryindex (udName (typeBar @HsLua.Core.Exception))

    , "initializing does not affect the stack" =:
      0 `shouldBeResultOf` do
        openlibs
        before <- gettop
        _ <- initTypeGeneric (\_ -> pure ()) typeBar
        after <- gettop
        return $ after - before
    ]

  , testGroup "lazy list"
    [ "Access an element of a lazy list stub" =:
      3 `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1,1,2,3,5,8]
        setglobal "list"
        _ <- dostring "return (list[4])"
        forcePeek $ peekIntegral @Int top

    , "Remaining list is not evaluated" =:
      2 `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1,1,2, Prelude.error "CRASH!"]
        setglobal "list"
        _ <- dostring "return (list[3])"
        forcePeek $ peekIntegral @Int top

    , "Out-of-bounds indices return nil" =:
      (TypeNil, TypeNil) `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1,4,9,16]
        setglobal "list"
        _ <- dostring "return list[0], list[5]"
        (,) <$> ltype (nth 1) <*> ltype (nth 2)

    , "Last evaled index is available in __lazylistindex" =:
      3 `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [9..17]
        setglobal "quuz"
        _ <- dostring "local foo = quuz[3]; return quuz.__lazylistindex"
        forcePeek $ peekIntegral @Int top

    , "__lazylistindex becomes `false` when all items are evaled" =:
      False `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1..3]
        setglobal "quuz"
        _ <- dostring "local foo = quuz[3]; return quuz.__lazylistindex"
        forcePeek $ peekBool top

    , "Input can be retrieved unchanged" =:
      LazyIntList [9..17] `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [9..17]
        setglobal "ninetofive"
        _ <- dostring "assert(ninetofive[3] == 11); return ninetofive"
        forcePeek $ peekUDGeneric typeLazyIntList top

    , "List is writable" =:
      LazyIntList [1, 4, 9, 16] `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [0,4,9,16]
        setglobal "list"
        OK <- dostring "list[1] = 1; return list"
        forcePeek $ peekUDGeneric typeLazyIntList top

    , "List can be extended" =:
      LazyIntList [1, 4, 9, 16, 25] `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1,4,9,16]
        setglobal "list"
        OK <- dostring "list[5] = 25; return list"
        forcePeek $ peekUDGeneric typeLazyIntList top

    , "List can be shortened" =:
      LazyIntList [1, 9, 27, 81] `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243]
        setglobal "list"
        OK <- dostring "list[5] = nil; return list"
        forcePeek $ peekUDGeneric typeLazyIntList top

    , "Setting element to nil shortenes the list" =:
      LazyIntList [1, 9, 27] `shouldBeResultOf` do
        openlibs
        pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243]
        setglobal "list"
        OK <- dostring "list[4] = nil; return list"
        forcePeek $ peekUDGeneric typeLazyIntList top

    , "Infinite lists are ok" =:
      233 `shouldBeResultOf` do
        openlibs
        let fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
        pushUD typeLazyIntList $ LazyIntList fibs
        setglobal "fibs"
        dostring "return fibs[14]" >>= \case
          OK -> forcePeek $ peekIntegral @Int top
          _ -> failLua =<< forcePeek (peekString top)
    ]

  , testGroup "possible properties"
    [ "tostring Quux" =:
      "Quux 11 \"eleven\"" `shouldBeResultOf` do
        openlibs
        pushUD typeQux $ Quux 11 "eleven"
        setglobal "quux"
        _ <- dostring "return tostring(quux)"
        forcePeek $ peekText top
    , "show Quux" =:
      "Quux 11 \"eleven\"" `shouldBeResultOf` do
        openlibs
        pushUD typeQux $ Quux 11 "eleven"
        setglobal "quux"
        _ <- dostring "return quux:show()"
        forcePeek $ peekText top

    , "access Quux.num" =:
      "12" `shouldBeResultOf` do
        openlibs
        pushUD typeQux $ Quux 12 "twelve"
        setglobal "quux"
        _ <- dostring "return quux.num"
        forcePeek $ peekText top

    , "access Quux.str" =:
      "thirteen!" `shouldBeResultOf` do
        openlibs
        pushUD typeQux $ Quux 13 "thirteen"
        setglobal "quux"
        _ <- dostring "return quux.num"
        _ <- dostring "quux.str = quux.str .. '!'; return quux.str"
        forcePeek $ peekText top

    , testGroup "alias"
      [ "read subelement via alias" =:
        13.37 `shouldBeResultOf` do
          openlibs
          pushUD typeQux $ Quuz (Point 13.37 0) undefined
          setglobal "quuz"
          _ <- dostring "return quuz.x"
          forcePeek $ peekRealFloat @Double top
      , "set subelement via alias" =:
        Point 42 1 `shouldBeResultOf` do
          openlibs
          pushUD typeQux $ Quuz (Point 1 1) undefined
          setglobal "quuz"
          _ <- dostring "quuz.x = 42; return quuz.point"
          -- msg <- forcePeek $ peekString top
          -- liftIO $ putStrLn msg
          forcePeek $ peekPoint top
      , "read subelement via integer alias" =:
        13.37 `shouldBeResultOf` do
          openlibs
          pushUD typeQux $ Quuz (Point 13.37 0) undefined
          setglobal "quuz"
          _ <- dostring "return quuz[1]"
          forcePeek $ peekRealFloat @Double top
      , "set subelement via integer alias" =:
        Point 42 1 `shouldBeResultOf` do
          openlibs
          pushUD typeQux $ Quuz (Point 1 1) undefined
          setglobal "quuz"
          _ <- dostring "quuz[1] = 42; return quuz.point"
          forcePeek $ peekPoint top
      , "non-aliased integer fields are nil" =:
        TypeNil `shouldBeResultOf` do
          openlibs
          pushUD typeQux (Quuz undefined undefined)
          setglobal "quuz"
          _ <- dostring "return quuz[3]"
          ltype top
      , "absent alias returns `nil`" =:
        TypeNil `shouldBeResultOf` do
          openlibs
          pushUD typeQux (Quux 9 "to five")
          setglobal "quux"
          dostring "return quux.x" >>= \case
            OK -> ltype top
            _ -> failLua =<< forcePeek (peekString top)
      , "alias can point to the element itself" =:
        9 `shouldBeResultOf` do
          openlibs
          pushUD typeLazyIntList (LazyIntList [1, 1, 1, 3, 5, 9, 17, 31])
          setglobal "tribonacci"
          dostring "return tribonacci.seq[6]" >>= \case
            OK -> forcePeek $ peekIntegral @Int top
            _ -> failLua =<< forcePeek (peekString top)
      ]
    ]
  ]

deftype :: LuaError e
        => Name                              -- ^ type name
        -> [(Operation, HaskellFunction e)]  -- ^ operations
        -> [Member e (HaskellFunction e) a]  -- ^ methods
        -> UDType e (HaskellFunction e) a
deftype = deftypeGeneric pushHaskellFunction

deftype' :: LuaError e
         => Name                  -- ^ type name
         -> [(Operation, HaskellFunction e)]  -- ^ operations
         -> [Member e (HaskellFunction e) a]  -- ^ methods
         -> Maybe (ListSpec e a itemtype)  -- ^ list access
         -> UDTypeWithList e (HaskellFunction e) a itemtype
deftype' = deftypeGeneric' pushHaskellFunction

-- | Pushes a userdata value of the given type.
pushUD :: LuaError e => UDTypeWithList e fn a itemtype -> a -> LuaE e ()
pushUD = pushUDGeneric (const (pure ()))

-- | Define a (meta) operation on a type.
operation :: Operation -> HaskellFunction e -> (Operation, HaskellFunction e)
operation = (,)

-- | Sample product type
data Foo = Foo Int String
  deriving (Eq, Show)

-- | Specify behavior of Foo values in Lua.
typeFoo :: LuaError e => UDType e (HaskellFunction e) Foo
typeFoo = deftype "Foo"
  [ operation Tostring show' ]
  [ property "num" "some number"
      (pushIntegral, \(Foo n _) -> n)
      (peekIntegral, \(Foo _ s) n -> Foo n s)
  , readonly "str" "some string" (pushString, \(Foo _ s) -> s)
  , methodGeneric "show" show'
  ]
  where
    show' = do
      foo <- forcePeek $ peekUDGeneric typeFoo (nthBottom 1)
      pushString (show foo)
      return (NumResults 1)


newtype Bar = Bar [Int]
  deriving (Eq, Show)

typeBar :: LuaError e => UDType e (HaskellFunction e) Bar
typeBar = deftype "Bar" []
  [ property' "nums" (seqType integerType) "some numbers"
    (pushList pushIntegral, \(Bar nums) -> nums)
    (peekList peekIntegral, \(Bar _) nums -> Bar nums)
  , alias "first" "first element" ["nums", IntegerIndex 1]
  ]

newtype LazyIntList = LazyIntList { fromLazyIntList :: [Int] }
  deriving (Eq, Show)

typeLazyIntList :: LuaError e
                => UDTypeWithList e (HaskellFunction e) LazyIntList Int
typeLazyIntList = deftype' "LazyIntList"
  [ operation Tostring $ do
      lazyList <- forcePeek $ peekUDGeneric typeLazyIntList (nthBottom 1)
      pushString (show lazyList)
      return (NumResults 1)
  ]
  [ alias "seq" "sequence" [] ]
  (Just ( (pushIntegral, fromLazyIntList)
        , (peekIntegral, \_ lst -> LazyIntList lst)
        ))

--
-- Sample sum type
--
data Qux
  = Quux Int String
  | Quuz Point Int
  deriving (Eq, Show)

data Point = Point Double Double
  deriving (Eq, Show)

pushPoint :: LuaError e => Pusher e Point
pushPoint (Point x y) = do
  newtable
  pushName "x" *> pushRealFloat x *> rawset (nth 3)
  pushName "y" *> pushRealFloat y *> rawset (nth 3)

peekPoint :: LuaError e => Peeker e Point
peekPoint idx = do
  x <- peekFieldRaw peekRealFloat "x" idx
  y <- peekFieldRaw peekRealFloat "y" idx
  return $ x `seq` y `seq` Point x y

pointType :: TypeSpec
pointType = recType
  [ ("x", numberType)
  , ("y", numberType)
  ]

showQux :: LuaError e => HaskellFunction e
showQux = do
  qux <- forcePeek $ peekQux (nthBottom 1)
  pushString $ show qux
  return (NumResults 1)

peekQux :: LuaError e => Peeker e Qux
peekQux = peekUDGeneric typeQux

typeQux :: LuaError e => UDType e (HaskellFunction e) Qux
typeQux = deftype "Qux"
  [ operation Tostring showQux ]
  [ methodGeneric "show" showQux
  , property' "num" integerType "some number"
      (pushIntegral, \case
          Quux n _ -> n
          Quuz _ n -> n)
      (peekIntegral, \case
          Quux _ s -> (`Quux` s)
          Quuz d _ -> Quuz d)

  , possibleProperty' "str" stringType "a string in Quux"
    (pushString, \case
        Quux _ s -> Actual s
        Quuz {}  -> Absent)
    (peekString, \case
        Quux n _ -> Actual . Quux n
        Quuz {}  -> const Absent)

  , possibleProperty' "point" pointType "a point in Quuz"
    (pushPoint, \case
        Quuz p _ -> Actual p
        Quux {}  -> Absent)
    (peekPoint, \case
        Quuz _ n -> Actual . (`Quuz` n)
        Quux {}  -> const Absent)

  , alias "x" "The x coordinate of a point in Quuz" ["point", "x"]
  , alias (IntegerIndex 1) "The x coordinate of a point in Quuz" ["point", "x"]
  ]