1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-| 6Module : Foreign.Lua.Types.Peekable 7Copyright : © 2007–2012 Gracjan Polak, 8 2012–2016 Ömer Sinan Ağacan, 9 2017-2020 Albert Krewinkel 10License : MIT 11Maintainer : Albert Krewinkel <tarleb+hslua@zeitkraut.de> 12Stability : beta 13Portability : non-portable (depends on GHC) 14 15Sending haskell objects to the lua stack. 16-} 17module Foreign.Lua.Types.Peekable 18 ( Peekable (..) 19 , peekKeyValuePairs 20 , peekList 21 , reportValueOnFailure 22 ) where 23 24import Control.Monad ((>=>)) 25import Data.ByteString (ByteString) 26import Data.Map (Map, fromList) 27import Data.Set (Set) 28import Foreign.Lua.Core as Lua 29import Foreign.Ptr (Ptr) 30 31import qualified Control.Monad.Catch as Catch 32import qualified Data.Set as Set 33import qualified Data.Text as T 34import qualified Data.ByteString.Lazy as BL 35import qualified Foreign.Lua.Peek as Peek 36import qualified Foreign.Lua.Utf8 as Utf8 37 38-- | Use @test@ to check whether the value at stack index @n@ has the correct 39-- type and use @peekfn@ to convert it to a haskell value if possible. Throws 40-- and exception if the test failes with the expected type name as part of the 41-- message. 42typeChecked :: String -- ^ expected type 43 -> (StackIndex -> Lua Bool) -- ^ pre-condition Checker 44 -> (StackIndex -> Lua a) -- ^ retrieval function 45 -> StackIndex -> Lua a 46typeChecked expectedType test peekfn idx = do 47 v <- test idx 48 if v then peekfn idx else mismatchError expectedType idx 49 50-- | Report the expected and actual type of the value under the given index if 51-- conversion failed. 52reportValueOnFailure :: String 53 -> (StackIndex -> Lua (Maybe a)) 54 -> StackIndex -> Lua a 55reportValueOnFailure expected peekMb idx = do 56 res <- peekMb idx 57 case res of 58 (Just x) -> return x 59 Nothing -> mismatchError expected idx 60 61-- | Return a Result error containing a message about the assertion failure. 62mismatchError :: String -> StackIndex -> Lua a 63mismatchError expected idx = do 64 actualType <- ltype idx >>= typename 65 actualValue <- Utf8.toString <$> tostring' idx <* pop 1 66 let msg = "expected " <> expected <> ", got '" <> 67 actualValue <> "' (" <> actualType <> ")" 68 Lua.throwMessage msg 69 70-- | A value that can be read from the Lua stack. 71class Peekable a where 72 -- | Check if at index @n@ there is a convertible Lua value and if so return 73 -- it. Throws a @'Lua.Exception'@ otherwise. 74 peek :: StackIndex -> Lua a 75 76instance Peekable () where 77 peek = reportValueOnFailure "nil" $ \idx -> do 78 isNil <- isnil idx 79 return (if isNil then Just () else Nothing) 80 81instance Peekable Lua.Integer where 82 peek = reportValueOnFailure "integer" tointeger 83 84instance Peekable Lua.Number where 85 peek = reportValueOnFailure "number" tonumber 86 87instance Peekable ByteString where 88 peek = Peek.peekByteString >=> Peek.force 89 90instance Peekable Bool where 91 peek = toboolean 92 93instance Peekable CFunction where 94 peek = reportValueOnFailure "C function" tocfunction 95 96instance Peekable (Ptr a) where 97 peek = reportValueOnFailure "userdata" touserdata 98 99instance Peekable Lua.State where 100 peek = reportValueOnFailure "Lua state (i.e., a thread)" tothread 101 102instance Peekable T.Text where 103 peek = Peek.peekText >=> Peek.force 104 105instance Peekable BL.ByteString where 106 peek = Peek.peekLazyByteString >=> Peek.force 107 108instance Peekable Prelude.Integer where 109 peek = Peek.peekIntegral >=> Peek.force 110 111instance Peekable Int where 112 peek = Peek.peekIntegral >=> Peek.force 113 114instance Peekable Float where 115 peek = Peek.peekRealFloat >=> Peek.force 116 117instance Peekable Double where 118 peek = Peek.peekRealFloat >=> Peek.force 119 120instance {-# OVERLAPS #-} Peekable [Char] where 121 peek = Peek.peekString >=> Peek.force 122 123instance Peekable a => Peekable [a] where 124 peek = peekList 125 126instance (Ord a, Peekable a, Peekable b) => Peekable (Map a b) where 127 peek = fmap fromList . peekKeyValuePairs 128 129instance (Ord a, Peekable a) => Peekable (Set a) where 130 peek = -- All keys with non-nil values are in the set 131 fmap (Set.fromList . map fst . filter snd) . peekKeyValuePairs 132 133-- | Read a table into a list 134peekList :: Peekable a => StackIndex -> Lua [a] 135peekList = typeChecked "table" istable $ \idx -> do 136 let elementsAt [] = return [] 137 elementsAt (i : is) = do 138 x <- (rawgeti idx i *> peek (nthFromTop 1)) `Catch.finally` pop 1 139 (x:) <$> elementsAt is 140 listLength <- fromIntegral <$> rawlen idx 141 inContext "Could not read list: " (elementsAt [1..listLength]) 142 143-- | Read a table into a list of pairs. 144peekKeyValuePairs :: (Peekable a, Peekable b) 145 => StackIndex -> Lua [(a, b)] 146peekKeyValuePairs = typeChecked "table" istable $ \idx -> do 147 let remainingPairs = do 148 res <- nextPair (if idx < 0 then idx - 1 else idx) 149 case res of 150 Nothing -> [] <$ return () 151 Just a -> (a:) <$> remainingPairs 152 pushnil 153 remainingPairs 154 -- ensure the remaining key is removed from the stack on exception 155 `Catch.onException` pop 1 156 157-- | Get the next key-value pair from a table. Assumes the last key to be on the 158-- top of the stack and the table at the given index @idx@. 159nextPair :: (Peekable a, Peekable b) 160 => StackIndex -> Lua (Maybe (a, b)) 161nextPair idx = do 162 hasNext <- next idx 163 if hasNext 164 then let pair = (,) <$> inContext "Could not read key of key-value pair: " 165 (peek (nthFromTop 2)) 166 <*> inContext "Could not read value of key-value pair: " 167 (peek (nthFromTop 1)) 168 in Just <$> pair `Catch.finally` pop 1 169 -- removes the value, keeps the key 170 else return Nothing 171 172-- | Specify a name for the context in which a computation is run. The name is 173-- added to the error message in case of an exception. 174inContext :: String -> Lua a -> Lua a 175inContext ctx op = Lua.errorConversion >>= \ec -> 176 Lua.addContextToException ec ctx op 177 178-- 179-- Tuples 180-- 181 182instance (Peekable a, Peekable b) => Peekable (a, b) where 183 peek = typeChecked "table" istable $ \idx -> 184 (,) <$> nthValue idx 1 <*> nthValue idx 2 185 186instance (Peekable a, Peekable b, Peekable c) => 187 Peekable (a, b, c) 188 where 189 peek = typeChecked "table" istable $ \idx -> 190 (,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 191 192instance (Peekable a, Peekable b, Peekable c, Peekable d) => 193 Peekable (a, b, c, d) 194 where 195 peek = typeChecked "table" istable $ \idx -> 196 (,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 197 <*> nthValue idx 4 198 199instance (Peekable a, Peekable b, Peekable c, 200 Peekable d, Peekable e) => 201 Peekable (a, b, c, d, e) 202 where 203 peek = typeChecked "table" istable $ \idx -> 204 (,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 205 <*> nthValue idx 4 <*> nthValue idx 5 206 207instance (Peekable a, Peekable b, Peekable c, 208 Peekable d, Peekable e, Peekable f) => 209 Peekable (a, b, c, d, e, f) 210 where 211 peek = typeChecked "table" istable $ \idx -> 212 (,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 213 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 214 215 216instance (Peekable a, Peekable b, Peekable c, Peekable d, 217 Peekable e, Peekable f, Peekable g) => 218 Peekable (a, b, c, d, e, f, g) 219 where 220 peek = typeChecked "table" istable $ \idx -> 221 (,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 222 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 223 <*> nthValue idx 7 224 225instance (Peekable a, Peekable b, Peekable c, Peekable d, 226 Peekable e, Peekable f, Peekable g, Peekable h) => 227 Peekable (a, b, c, d, e, f, g, h) 228 where 229 peek = typeChecked "table" istable $ \idx -> 230 (,,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 231 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 232 <*> nthValue idx 7 <*> nthValue idx 8 233 234-- | Helper function to get the nth table value 235nthValue :: Peekable a => StackIndex -> Lua.Integer -> Lua a 236nthValue idx n = do 237 rawgeti idx n 238 peek (-1) `Catch.finally` pop 1 239