{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Foreign.Lua.Types.Peekable
( Peekable (..)
, peekKeyValuePairs
, peekList
, reportValueOnFailure
) where
import Data.ByteString (ByteString)
import Data.Map (Map, fromList)
import Data.Set (Set)
import Data.Monoid ((<>))
import Foreign.Lua.Core as Lua
import Foreign.Ptr (Ptr)
import Text.Read (readMaybe)
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 Foreign.Lua.Utf8 as Utf8
typeChecked :: String
-> (StackIndex -> Lua Bool)
-> (StackIndex -> Lua a)
-> StackIndex -> Lua a
typeChecked expectedType test peekfn idx = do
v <- test idx
if v then peekfn idx else mismatchError expectedType idx
reportValueOnFailure :: String
-> (StackIndex -> Lua (Maybe a))
-> StackIndex -> Lua a
reportValueOnFailure expected peekMb idx = do
res <- peekMb idx
case res of
(Just x) -> return x
Nothing -> mismatchError expected idx
mismatchError :: String -> StackIndex -> Lua a
mismatchError expected idx = do
actualType <- ltype idx >>= typename
actualValue <- Utf8.toString <$> tostring' idx <* pop 1
let msg = "expected " <> expected <> ", got '" <>
actualValue <> "' (" <> actualType <> ")"
Lua.throwException msg
class Peekable a where
peek :: StackIndex -> Lua 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 = reportValueOnFailure "string" $ \idx -> do
pushvalue idx
tostring stackTop <* pop 1
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 = fmap Utf8.toText . peek
instance Peekable BL.ByteString where
peek = fmap BL.fromStrict . peek
instance Peekable Prelude.Integer where
peek = peekInteger
instance Peekable Int where
peek = fmap fromIntegral <$> peekInteger
instance Peekable Float where
peek = peekRealFloat
instance Peekable Double where
peek = peekRealFloat
instance {-# OVERLAPS #-} Peekable [Char] where
peek = fmap Utf8.toString . peek
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 =
fmap (Set.fromList . map fst . filter snd) . peekKeyValuePairs
peekInteger :: StackIndex -> Lua Prelude.Integer
peekInteger idx = ltype idx >>= \case
TypeString -> do
s <- peek idx
case readMaybe s of
Just x -> return x
Nothing -> mismatchError "integer" idx
_ -> fromIntegral <$> (peek idx :: Lua Lua.Integer)
peekRealFloat :: (Read a, RealFloat a) => StackIndex -> Lua a
peekRealFloat idx = ltype idx >>= \case
TypeString -> do
s <- peek idx
case readMaybe s of
Just x -> return x
Nothing -> mismatchError "number" idx
_ -> realToFrac <$> (peek idx :: Lua Lua.Number)
peekList :: Peekable a => StackIndex -> Lua [a]
peekList = typeChecked "table" istable $ \idx -> do
let elementsAt [] = return []
elementsAt (i : is) = do
x <- (rawgeti idx i *> peek (nthFromTop 1)) `Catch.finally` pop 1
(x:) <$> elementsAt is
listLength <- fromIntegral <$> rawlen idx
inContext "Could not read list: " (elementsAt [1..listLength])
peekKeyValuePairs :: (Peekable a, Peekable b)
=> StackIndex -> Lua [(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
`Catch.onException` pop 1
nextPair :: (Peekable a, Peekable b)
=> StackIndex -> Lua (Maybe (a, b))
nextPair idx = do
hasNext <- next idx
if hasNext
then let pair = (,) <$> inContext "Could not read key of key-value pair: "
(peek (nthFromTop 2))
<*> inContext "Could not read value of key-value pair: "
(peek (nthFromTop 1))
in Just <$> pair `Catch.finally` pop 1
else return Nothing
inContext :: String -> Lua a -> Lua a
inContext ctx = Lua.withExceptionMessage (ctx <>)
instance (Peekable a, Peekable b) => Peekable (a, b) where
peek = typeChecked "table" istable $ \idx ->
(,) <$> nthValue idx 1 <*> nthValue idx 2
instance (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 (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 (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 (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 (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 (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
nthValue :: Peekable a => StackIndex -> Lua.Integer -> Lua a
nthValue idx n = do
rawgeti idx n
peek (-1) `Catch.finally` pop 1