1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module : Main
Copyright : © 2023-2024 Albert Krewinkel
License : MIT
Maintainer : Albert Krewinkel <tarleb@hslua.org>
Tests for type specifiers.
-}
import Control.Monad (when)
import Data.String (fromString)
import HsLua.Core
import HsLua.Core.Types
import HsLua.Marshalling
import HsLua.Typing
import Lua.Arbitrary ()
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit ((@?=), testCase)
import Test.Tasty.QuickCheck
import Test.QuickCheck.Instances ()
import qualified HsLua.Core as HsLua
import qualified Test.QuickCheck.Monadic as QC
-- | Run this spec.
main :: IO ()
main = defaultMain tests
-- | Aeson tests
tests :: TestTree
tests = testGroup "hslua-typespec"
[ testGroup "string representation"
[ testCase "any" $ "any" @?= anyType
, testCase "boolean" $ "boolean" @?= booleanType
, testCase "function" $ "function" @?= functionType
, testCase "integer" $ "integer" @?= integerType
, testCase "nil" $ "nil" @?= nilType
, testCase "number" $ "number" @?= numberType
, testCase "string" $ "string" @?= stringType
, testCase "table" $ "table" @?= tableType
, testCase "userdata" $ "userdata" @?= userdataType
, testCase "light userdata" $
"light userdata" @?= lightUserdataType
, testCase "sequence" $
"{string,...}" @?= seqType stringType
, testCase "alternative" $
"string|boolean|number" @?= stringType #|# (booleanType #|# numberType)
, testCase "sequence of alternatives" $
"{string|number,...}" @?=
seqType (stringType #|# numberType)
, testCase "string or strings" $
"string|{string,...}" @?=
stringType #|# seqType stringType
, testCase "strings or string" $
"{string,...}|string" @?=
seqType stringType #|# stringType
, testCase "sequence of sequences" $
"{{number,...}, ... }" @?=
seqType (seqType "number")
]
, testGroup "to string"
[ testCase "any" $ typeSpecToString anyType @?= "any"
, testCase "boolean" $ typeSpecToString booleanType @?= "boolean"
, testCase "function" $ typeSpecToString functionType @?= "function"
, testCase "number" $ typeSpecToString numberType @?= "number"
, testCase "string" $ typeSpecToString stringType @?= "string"
, testCase "table" $ typeSpecToString tableType @?= "table"
, testCase "userdata" $ typeSpecToString userdataType @?= "userdata"
, testCase "sequence" $
seqType stringType @?= "{string,...}"
]
, testGroup "operators"
[ testGroup "#|#"
-- These should be property tests
[ testCase "combining basic types yields sum type" $
booleanType #|# numberType @?= SumType [booleanType, numberType]
, testCase "any is the unit" $ do
booleanType #|# anyType @?= anyType
anyType #|# booleanType @?= anyType
, testCase "void is zero" $ do
booleanType #|# voidType @?= booleanType
voidType #|# numberType @?= numberType
]
]
, testGroup "Marshalling"
[ testProperty "Roundtrip TypeSpec" $
assertRoundtripEqual pushTypeSpec peekTypeSpec
, testProperty "Roundtrip TypeDocs" $
assertRoundtripEqual pushTypeDoc peekTypeDoc
]
]
instance Arbitrary TypeSpec where
arbitrary = arbitraryTypeSpec 3
shrink = shrinkTypeSpec
instance Arbitrary TypeDocs where
arbitrary = TypeDocs
<$> arbitrary
<*> arbitrary
<*> arbitrary
shrink td = (\ts -> td{ typeSpec = ts}) <$> shrink (typeSpec td)
instance Arbitrary Name where
arbitrary = Name . fromString <$> arbitrary
arbitraryTypeSpec :: Int -> Gen TypeSpec
arbitraryTypeSpec size = frequency
[ (8, BasicType . toType <$> arbitrary)
, (1, NamedType <$> arbitrary)
, (3, resize (size - 1) $ SeqType <$> arbitrary)
, (2, resize (size - 1) $ SumType <$> arbitrary)
, (2, resize (size - 1) $ RecType <$> arbitrary)
, (1, resize (size - 1) $ FunType <$> arbitrary <*> arbitrary)
, (1, return AnyType)
]
shrinkTypeSpec :: TypeSpec -> [TypeSpec]
shrinkTypeSpec = \case
SumType cs -> SumType <$> shrinkList shrink cs
SeqType x -> shrink x
FunType d c -> (FunType c <$> shrinkList shrinkTypeSpec d) ++
((`FunType` d) <$> shrinkList shrinkTypeSpec c)
x -> shrinkNothing x
assertRoundtripEqual :: Eq a
=> Pusher HsLua.Exception a -> Peeker HsLua.Exception a
-> a -> Property
assertRoundtripEqual pushX peekX x = QC.monadicIO $ do
y <- QC.run $ roundtrip pushX peekX x
QC.assert (x == y)
roundtrip :: Pusher HsLua.Exception a -> Peeker HsLua.Exception a -> a -> IO a
roundtrip pushX peekX x = run $ do
pushX x
size <- gettop
when (size /= 1) $
failLua $ "not the right amount of elements on the stack: " ++ show size
result <- forcePeek $ peekX top
afterPeekSize <- gettop
when (afterPeekSize /= 1) $
failLua $ "peeking modified the stack: " ++ show afterPeekSize
return result
|
