{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeApplications #-}

module HsLua.Class.Peekable

( Peekable (..)

, PeekError (..)

, peekKeyValuePairs

, peekList

, reportValueOnFailure

, inContext

) where

import Control.Monad ((>=>))

import Data.ByteString (ByteString)

import Data.Map (Map, fromList)

import Data.Set (Set)

import HsLua.Core as Lua

import HsLua.Marshalling.Peek (runPeeker)

import Foreign.Ptr (Ptr)

import qualified Control.Monad.Catch as Catch

import qualified Data.Set as Set

import qualified Data.Text as T

import qualified Data.ByteString.Lazy as BL

import qualified HsLua.Core.Unsafe as Unsafe

import qualified HsLua.Marshalling as Peek

-- | Use @test@ to check whether the value at stack index @n@ has the

typeChecked :: forall e a. LuaError e

=> ByteString -- ^ expected type

-> (StackIndex -> LuaE e Bool) -- ^ pre-condition Checker

-> (StackIndex -> LuaE e a) -- ^ retrieval function

-> StackIndex -> LuaE e a

typeChecked expectedType test peekfn idx = do

v <- test idx

if v

then peekfn idx

else throwTypeMismatchError expectedType idx

-- | Report the expected and actual type of the value under the given

reportValueOnFailure :: forall e a. PeekError e

=> ByteString

-> (StackIndex -> LuaE e (Maybe a))

-> StackIndex -> LuaE e a

reportValueOnFailure expected peekMb idx = do

res <- peekMb idx

case res of

(Just x) -> return x

Nothing -> throwTypeMismatchError expected idx

-- | A value that can be read from the Lua stack.

class Peekable a where

-- | Check if at index @n@ there is a convertible Lua value and if so return

-- it. Throws a @'Lua.Exception'@ otherwise.

peek :: PeekError e => StackIndex -> LuaE e a

instance Peekable () where

peek = reportValueOnFailure "nil" $ \idx -> do

isNil <- isnil idx

return (if isNil then Just () else Nothing)

instance Peekable Lua.Integer where

peek = reportValueOnFailure "integer" tointeger

instance Peekable Lua.Number where

peek = reportValueOnFailure "number" tonumber

instance Peekable ByteString where

peek = runPeeker Peek.peekByteString >=> Peek.force

instance Peekable Bool where

peek = toboolean

instance Peekable CFunction where

peek = reportValueOnFailure "C function" tocfunction

instance Peekable (Ptr a) where

peek = reportValueOnFailure "userdata" touserdata

instance Peekable Lua.State where

peek = reportValueOnFailure "Lua state (i.e., a thread)" tothread

instance Peekable T.Text where

peek = runPeeker Peek.peekText >=> Peek.force

instance Peekable BL.ByteString where

peek = runPeeker Peek.peekLazyByteString >=> Peek.force

instance Peekable Prelude.Integer where

peek = runPeeker Peek.peekIntegral >=> Peek.force

instance Peekable Int where

peek = runPeeker Peek.peekIntegral >=> Peek.force

instance Peekable Float where

peek = runPeeker Peek.peekRealFloat >=> Peek.force

instance Peekable Double where

peek = runPeeker Peek.peekRealFloat >=> Peek.force

instance {-# OVERLAPS #-} Peekable [Char] where

peek = runPeeker Peek.peekString >=> Peek.force

instance Peekable a => Peekable [a] where

peek = peekList

instance (Ord a, Peekable a, Peekable b) => Peekable (Map a b) where

peek = fmap fromList . peekKeyValuePairs

instance (Ord a, Peekable a) => Peekable (Set a) where

peek = -- All keys with non-nil values are in the set

fmap (Set.fromList . map fst . filter snd) . peekKeyValuePairs

-- | Read a table into a list

peekList :: (PeekError e, Peekable a) => StackIndex -> LuaE e [a]

peekList = typeChecked "table" istable $ \idx -> do

let elementsAt [] = return []

elementsAt (i : is) = do

x <- (rawgeti idx i *> peek top) `Catch.finally` pop 1

(x:) <$> elementsAt is

listLength <- fromIntegral <$> rawlen idx

inContext "Could not read list:" (elementsAt [1..listLength])

-- | Read a table into a list of pairs.

peekKeyValuePairs :: (Peekable a, Peekable b, PeekError e)

=> StackIndex -> LuaE e [(a, b)]

peekKeyValuePairs = typeChecked "table" istable $ \idx -> do

let remainingPairs = do

res <- nextPair (if idx < 0 then idx - 1 else idx)

case res of

Nothing -> [] <$ return ()

Just a -> (a:) <$> remainingPairs

pushnil

remainingPairs

-- ensure the remaining key is removed from the stack on exception

`Catch.onException` pop 1

-- | Get the next key-value pair from a table. Assumes the last key to

nextPair :: (PeekError e, Peekable a, Peekable b)

=> StackIndex -> LuaE e (Maybe (a, b))

nextPair idx = do

hasNext <- Unsafe.next idx

if hasNext

then let pair = (,) <$> inContext "Could not read key of key-value pair:"

(peek (nth 2))

<*> inContext "Could not read value of key-value pair:"

(peek (nth 1))

in Just <$> pair `Catch.finally` pop 1

-- removes the value, keeps the key

else return Nothing

-- | Specify a name for the context in which a computation is run. The

inContext :: forall e a. PeekError e

=> String -> LuaE e a -> LuaE e a

inContext ctx op = try op >>= \case

Right x -> return x

Left (err :: e) -> Catch.throwM $

luaException @e (ctx ++ "\n\t" ++ messageFromException err)

-- | Exceptions that are to be used with 'peek' and similar functions

class LuaError e => PeekError e where

messageFromException :: e -> String

instance PeekError Lua.Exception where

messageFromException = Lua.exceptionMessage

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b) =>

Peekable (a, b)

where

peek = typeChecked "table" istable $ \idx ->

(,) <$> nthValue idx 1 <*> nthValue idx 2

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c) =>

Peekable (a, b, c)

where

peek = typeChecked "table" istable $ \idx ->

(,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c, Peekable d) =>

Peekable (a, b, c, d)

where

peek = typeChecked "table" istable $ \idx ->

(,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

<*> nthValue idx 4

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c, Peekable d, Peekable e) =>

Peekable (a, b, c, d, e)

where

peek = typeChecked "table" istable $ \idx ->

(,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

<*> nthValue idx 4 <*> nthValue idx 5

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c, Peekable d, Peekable e, Peekable f) =>

Peekable (a, b, c, d, e, f)

where

peek = typeChecked "table" istable $ \idx ->

(,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

<*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c, Peekable d,

Peekable e, Peekable f, Peekable g) =>

Peekable (a, b, c, d, e, f, g)

where

peek = typeChecked "table" istable $ \idx ->

(,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

<*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6

<*> nthValue idx 7

instance {-# OVERLAPPABLE #-}

(Peekable a, Peekable b, Peekable c, Peekable d,

Peekable e, Peekable f, Peekable g, Peekable h) =>

Peekable (a, b, c, d, e, f, g, h)

where

peek = typeChecked "table" istable $ \idx ->

(,,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3

<*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6

<*> nthValue idx 7 <*> nthValue idx 8

-- | Helper function to get the nth table value

nthValue :: (PeekError e, Peekable a)

=> StackIndex -> Lua.Integer -> LuaE e a

nthValue idx n = do

_ <- rawgeti idx n

peek top `Catch.finally` pop 1