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