Skip to content

Commit f15f4fa

Browse files
bladyjokerbladyjoker
committed
Switched to using Hedgehog
1 parent 650f57a commit f15f4fa

File tree

5 files changed

+95
-110
lines changed

5 files changed

+95
-110
lines changed

‎lambda-buffers-compiler/lambda-buffers-compiler.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -155,12 +155,14 @@ test-suite tests
155155
build-depends:
156156
, containers
157157
, generic-lens
158+
, hedgehog
158159
, lambda-buffers-compiler
159160
, lambda-buffers-compiler-pb >=0.1
160161
, nonempty-containers
161162
, proto-lens >=0.7
162163
, QuickCheck >=2.14
163164
, tasty >=1.4
165+
, tasty-hedgehog
164166
, tasty-hunit >=0.10
165167
, tasty-quickcheck >=0.10
166168
, text >=1.2

‎lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler.hs‎

Lines changed: 23 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -2,15 +2,16 @@ module Test.LambdaBuffers.Compiler (test) where
22

33
import Control.Lens ((&), (.~))
44
import Data.ProtoLens (Message (defMessage))
5+
import Hedgehog qualified as H
6+
import Hedgehog.Gen qualified as H
57
import LambdaBuffers.Compiler (runCompiler)
68
import Proto.Compiler (CompilerOutput)
79
import Proto.Compiler_Fields (compilerResult)
810
import Test.LambdaBuffers.Compiler.Gen (genCompilerInput)
911
import Test.LambdaBuffers.Compiler.Gen.Mutation qualified as Mut
10-
import Test.QuickCheck (forAll, forAllBlind)
11-
import Test.QuickCheck qualified as QC
1212
import Test.Tasty (TestTree, testGroup)
13-
import Test.Tasty.QuickCheck (testProperty)
13+
import Test.Tasty.HUnit (HasCallStack)
14+
import Test.Tasty.Hedgehog (testProperty)
1415

1516
test :: TestTree
1617
test =
@@ -20,34 +21,29 @@ test =
2021
, allCorrectCompInpCompileAfterBenignMut
2122
]
2223

23-
compilationOk :: CompilerOutput -> Bool
24-
compilationOk compOut = compOut == (defMessage & compilerResult .~ defMessage)
24+
compilationOk :: H.MonadTest m => CompilerOutput -> m ()
25+
compilationOk compOut = compOut H.=== (defMessage & compilerResult .~ defMessage)
2526

26-
allCorrectCompInpCompile :: TestTree
27-
allCorrectCompInpCompile = testProperty "All correct CompilerInputs must compile" (forAll genCompilerInput (compilationOk . runCompiler))
27+
allCorrectCompInpCompile :: HasCallStack => TestTree
28+
allCorrectCompInpCompile = testProperty "All correct CompilerInputs must compile" (H.property $ H.forAll genCompilerInput >>= compilationOk . runCompiler)
2829

29-
allCorrectCompInpCompileAfterBenignMut :: TestTree
30+
allCorrectCompInpCompileAfterBenignMut :: HasCallStack => TestTree
3031
allCorrectCompInpCompileAfterBenignMut =
3132
testProperty
3233
"All correct CompilerInputs must compile after a benign mutation"
33-
$ forAll
34-
genCompilerInput
35-
( \compInp ->
36-
forAll
37-
( QC.elements
38-
[ Mut.shuffleModules
39-
, Mut.shuffleTyDefs
40-
]
41-
)
42-
( \mut ->
43-
forAllBlind
44-
(Mut.mutFn mut compInp)
45-
( \(compInp', _) ->
46-
let compOut = runCompiler compInp
47-
compOut' = runCompiler compInp'
48-
in compilationOk compOut && compilationOk compOut'
49-
)
50-
)
51-
)
34+
$ H.property
35+
$ do
36+
compInp <- H.forAll genCompilerInput
37+
mut <-
38+
H.forAll $
39+
H.element
40+
[ Mut.shuffleModules
41+
, Mut.shuffleTyDefs
42+
]
43+
(compInp', _) <- H.forAllWith (const "mutation") (Mut.mutFn mut compInp)
44+
let compOut = runCompiler compInp
45+
compOut' = runCompiler compInp'
46+
compilationOk compOut
47+
compilationOk compOut'
5248

5349
-- TODO(bladyjoker): Add error producing mutations.

‎lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler/Gen.hs‎

Lines changed: 51 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -17,56 +17,58 @@ import Data.Text (Text)
1717
import Data.Text qualified as Text
1818
import Data.Traversable (for)
1919
import GHC.Enum qualified as Int
20+
import Hedgehog qualified as H
21+
import Hedgehog.Gen qualified as H
22+
import Hedgehog.Range qualified as H
2023
import Proto.Compiler (ClassName, CompilerInput, ConstrName, Kind, Kind'KindRef (Kind'KIND_REF_TYPE), Module, ModuleName, ModuleNamePart, SourceInfo, Sum, Sum'Constructor, Ty, TyAbs, TyArg, TyBody, TyDef, TyName, VarName)
2124
import Proto.Compiler_Fields (argKind, argName, column, constrName, constructors, fields, file, foreignTyRef, kindArrow, kindRef, left, localTyRef, moduleName, modules, name, ntuple, parts, posFrom, posTo, right, row, sourceInfo, tyAbs, tyApp, tyArgs, tyBody, tyFunc, tyName, tyRef, tyVar, typeDefs, varName)
2225
import Proto.Compiler_Fields qualified as P
23-
import Test.LambdaBuffers.Compiler.Gen.Utils (distribute, indexBy, nesetOf, setOf, vecOf)
24-
import Test.QuickCheck qualified as QC (arbitraryPrintableChar)
25-
import Test.QuickCheck.Gen qualified as QC
26+
import Test.LambdaBuffers.Compiler.Gen.Utils (distribute, indexBy)
27+
import Test.Tasty.Hedgehog ()
2628

2729
-- | Upper bound on various generators
2830
limit :: Int
2931
limit = 5
3032

3133
-- | Names
32-
genAlphaNum :: QC.Gen Char
33-
genAlphaNum = QC.oneof [QC.chooseEnum ('a', 'z'), QC.chooseEnum ('A', 'Z'), QC.chooseEnum ('0', '9')]
34+
genAlphaNum :: H.Gen Char
35+
genAlphaNum = H.alphaNum
3436

35-
genUpperCamelCase :: Int -> QC.Gen Text
36-
genUpperCamelCase len = do
37-
h <- QC.chooseEnum ('A', 'Z')
38-
t <- QC.vectorOf len genAlphaNum
37+
genUpperCamelCase :: H.Gen Text
38+
genUpperCamelCase = do
39+
h <- H.upper
40+
t <- H.list (H.linear 1 limit) genAlphaNum
3941
return $ Text.pack $ h : t
4042

41-
genModuleNamePart :: QC.Gen ModuleNamePart
43+
genModuleNamePart :: H.Gen ModuleNamePart
4244
genModuleNamePart = do
43-
mnp <- genUpperCamelCase 10
45+
mnp <- genUpperCamelCase
4446
return $ defMessage & name .~ mnp
4547

46-
genModuleName :: QC.Gen ModuleName
48+
genModuleName :: H.Gen ModuleName
4749
genModuleName = do
48-
ps <- QC.chooseInt (1, limit) >>= vecOf genModuleNamePart
50+
ps <- H.list (H.linear 1 limit) genModuleNamePart
4951
return $ defMessage & parts .~ ps
5052

51-
genTyName :: QC.Gen TyName
53+
genTyName :: H.Gen TyName
5254
genTyName = do
53-
n <- genUpperCamelCase 10
55+
n <- genUpperCamelCase
5456
return $ defMessage & name .~ n
5557

56-
_genClassName :: QC.Gen ClassName
58+
_genClassName :: H.Gen ClassName
5759
_genClassName = do
58-
n <- genUpperCamelCase 10
60+
n <- genUpperCamelCase
5961
return $ defMessage & name .~ n
6062

61-
genConstrName :: QC.Gen ConstrName
63+
genConstrName :: H.Gen ConstrName
6264
genConstrName = do
63-
n <- genUpperCamelCase 10
65+
n <- genUpperCamelCase
6466
return $ defMessage & name .~ n
6567

66-
genVarName :: QC.Gen VarName
68+
genVarName :: H.Gen VarName
6769
genVarName = do
68-
h <- QC.chooseEnum ('a', 'z')
69-
t <- QC.vectorOf 4 (QC.chooseEnum ('a', 'z'))
70+
h <- H.lower
71+
t <- H.list (H.linear 1 4) H.lower
7072
return $ defMessage & name .~ Text.pack (h : t)
7173

7274
starKind :: Kind
@@ -80,33 +82,33 @@ kindOf tyabs = case tyabs ^. tyArgs of
8082
& kindArrow . left .~ (a ^. argKind)
8183
& kindArrow . right .~ kindOf (tyabs & tyArgs .~ args)
8284

83-
genTyArg :: VarName -> QC.Gen TyArg
85+
genTyArg :: VarName -> H.Gen TyArg
8486
genTyArg vn = do
8587
return $
8688
defMessage
8789
& argName .~ vn
8890
& argKind .~ starKind -- TODO(bladyjoker): Gen arbitrary kinds.
8991

90-
genSum :: TyDefs -> Set TyArg -> NESet ConstrName -> QC.Gen Sum
92+
genSum :: TyDefs -> Set TyArg -> NESet ConstrName -> H.Gen Sum
9193
genSum tydefs args ctorNs = do
9294
let (ctorN :| ctorNs') = NESet.toList ctorNs
93-
ctorNs'' <- QC.sublistOf (toList ctorNs')
95+
ctorNs'' <- H.subsequence ctorNs'
9496
ctors <- for (ctorN :| ctorNs'') (genConstructor tydefs args)
9597
return $ defMessage & constructors .~ toList ctors
9698

97-
genTy :: Kind -> TyDefs -> Set TyArg -> QC.Gen Ty
99+
genTy :: Kind -> TyDefs -> Set TyArg -> H.Gen Ty
98100
genTy kind tydefs tyargs =
99-
QC.oneof $
101+
H.choice $
100102
NESet.withNonEmpty [] (genTyVar kind) tyargs
101103
<> genTyRef kind tydefs
102104
<> genTyApp kind tydefs tyargs
103105

104-
genTyRef :: Kind -> TyDefs -> [QC.Gen Ty]
106+
genTyRef :: Kind -> TyDefs -> [H.Gen Ty]
105107
genTyRef kind tydefs = case [tyd | tyd <- Map.toList tydefs, kindOf (snd tyd ^. tyAbs) == kind] of
106108
[] -> []
107109
tyds ->
108110
[ do
109-
tydef <- QC.elements tyds
111+
tydef <- H.element tyds
110112
case fst tydef of
111113
Left (mn, tyn) ->
112114
return $
@@ -116,16 +118,16 @@ genTyRef kind tydefs = case [tyd | tyd <- Map.toList tydefs, kindOf (snd tyd ^.
116118
Right tyn -> return $ defMessage & tyRef . localTyRef . tyName .~ tyn
117119
]
118120

119-
genTyVar :: Kind -> NESet TyArg -> [QC.Gen Ty]
121+
genTyVar :: Kind -> NESet TyArg -> [H.Gen Ty]
120122
genTyVar kind args = case [tyarg | tyarg <- toList args, tyarg ^. argKind == kind] of
121123
[] -> []
122124
tyargs ->
123125
[ do
124-
tyarg <- QC.elements tyargs
126+
tyarg <- H.element tyargs
125127
return $ defMessage & tyVar . varName .~ (tyarg ^. argName)
126128
]
127129

128-
genTyApp :: Kind -> TyDefs -> Set TyArg -> [QC.Gen Ty]
130+
genTyApp :: Kind -> TyDefs -> Set TyArg -> [H.Gen Ty]
129131
genTyApp kind tydefs args =
130132
let kindFunc =
131133
defMessage
@@ -143,36 +145,36 @@ genTyApp kind tydefs args =
143145
& tyApp . tyArgs .~ [tyarg] -- TODO(bladyjoker): Generate list arguments
144146
]
145147

146-
genConstructor :: TyDefs -> Set TyArg -> ConstrName -> QC.Gen Sum'Constructor
148+
genConstructor :: TyDefs -> Set TyArg -> ConstrName -> H.Gen Sum'Constructor
147149
genConstructor tydefs args cn = do
148-
tys <- QC.chooseInt (0, limit) >>= vecOf (genTy starKind tydefs args)
150+
tys <- H.list (H.linear 0 limit) (genTy starKind tydefs args)
149151
return $
150152
defMessage
151153
& constrName .~ cn
152154
& P.product . ntuple . fields .~ tys
153155

154-
genTyBodySum :: TyDefs -> Set TyArg -> NESet ConstrName -> QC.Gen TyBody
156+
genTyBodySum :: TyDefs -> Set TyArg -> NESet ConstrName -> H.Gen TyBody
155157
genTyBodySum tydefs args ctors = do
156158
b <- genSum tydefs args ctors
157159
return $ defMessage & P.sum .~ b
158160

159-
genTyBodyOpaque :: QC.Gen TyBody
161+
genTyBodyOpaque :: H.Gen TyBody
160162
genTyBodyOpaque = return $ defMessage & P.opaque .~ defMessage
161163

162-
genTyBody :: TyDefs -> Set TyArg -> NESet ConstrName -> QC.Gen TyBody
164+
genTyBody :: TyDefs -> Set TyArg -> NESet ConstrName -> H.Gen TyBody
163165
genTyBody tydefs args ctorNs =
164-
QC.oneof $
166+
H.choice $
165167
[ genTyBodyOpaque
166168
]
167169
-- Gen TyBody'Sum only if there's some TyDefs and TyArgs available
168170
<> [genTyBodySum tydefs args ctorNs | not (tydefs == mempty && args == mempty)]
169171

170-
genTyAbs :: TyDefs -> NESet ConstrName -> QC.Gen TyAbs
172+
genTyAbs :: TyDefs -> NESet ConstrName -> H.Gen TyAbs
171173
genTyAbs tydefs ctorNs = do
172174
vns <-
173175
if tydefs == mempty
174176
then return mempty
175-
else QC.chooseInt (0, limit) >>= setOf genVarName
177+
else H.set (H.linear 0 limit) genVarName
176178
args <- for (Set.toList vns) genTyArg
177179
body <- genTyBody tydefs (Set.fromList args) ctorNs
178180
return $
@@ -182,18 +184,18 @@ genTyAbs tydefs ctorNs = do
182184

183185
type TyDefs = Map (Either (ModuleName, TyName) TyName) TyDef
184186

185-
genTyDef :: TyDefs -> TyName -> NESet ConstrName -> QC.Gen TyDef
187+
genTyDef :: TyDefs -> TyName -> NESet ConstrName -> H.Gen TyDef
186188
genTyDef tydefs tyn ctors = do
187189
tyabs <- genTyAbs tydefs ctors
188190
withSourceInfo $
189191
defMessage
190192
& tyName .~ tyn
191193
& tyAbs .~ tyabs
192194

193-
genModule :: Map ModuleName Module -> ModuleName -> QC.Gen Module
195+
genModule :: Map ModuleName Module -> ModuleName -> H.Gen Module
194196
genModule availableMods mn = do
195-
tyNs <- QC.chooseInt (0, limit) >>= nesetOf genTyName
196-
ctorNs <- QC.chooseInt (length tyNs, length tyNs * limit) >>= nesetOf genConstrName
197+
tyNs <- NESet.fromList <$> H.nonEmpty (H.linear 0 limit) genTyName
198+
ctorNs <- H.set (H.linear (length tyNs) (length tyNs * limit)) genConstrName
197199
tyNsWithCtorNs <- Map.map NESet.fromList <$> distribute (toList ctorNs) (NESet.toSet tyNs)
198200
let foreignTyDefs = collectTyDefs availableMods
199201
tydefs <-
@@ -216,9 +218,9 @@ genModule availableMods mn = do
216218
(\(m, tydef) -> Left (m ^. moduleName, tydef ^. tyName))
217219
[(m, tydef) | m <- toList mods, tydef <- m ^. typeDefs]
218220

219-
genCompilerInput :: QC.Gen CompilerInput
221+
genCompilerInput :: H.Gen CompilerInput
220222
genCompilerInput = do
221-
mns <- QC.chooseInt (0, limit) >>= setOf genModuleName
223+
mns <- H.set (H.linear 0 limit) genModuleName
222224
ms <-
223225
foldM
224226
( \availableMods mn -> do
@@ -230,10 +232,10 @@ genCompilerInput = do
230232
return $ defMessage & modules .~ toList ms
231233

232234
-- | Utils
233-
withSourceInfo :: HasField a "sourceInfo" SourceInfo => a -> QC.Gen a
235+
withSourceInfo :: HasField a "sourceInfo" SourceInfo => a -> H.Gen a
234236
withSourceInfo msg = do
235-
f <- Text.pack <$> vecOf QC.arbitraryPrintableChar 10
236-
i <- QC.chooseInt (0, Int.maxBound)
237+
f <- Text.pack <$> H.list (H.linear 1 10) H.unicodeAll
238+
i <- H.int (H.linear 0 Int.maxBound)
237239
let pos =
238240
defMessage
239241
& row .~ fromIntegral i

‎lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler/Gen/Mutation.hs‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,32 +4,34 @@ import Control.Lens ((&), (.~), (^.))
44
import Data.List.NonEmpty (nonEmpty)
55
import Data.ProtoLens (Message (messageName))
66
import Data.Proxy (Proxy (Proxy))
7+
import Hedgehog qualified as H
8+
import Hedgehog.Gen qualified as H
79
import Proto.Compiler (CompilerError, CompilerInput, CompilerOutput, CompilerOutput'CompilerOutput (CompilerOutput'CompilerError, CompilerOutput'CompilerResult), CompilerResult)
810
import Proto.Compiler_Fields (maybe'compilerOutput, modules, typeDefs)
911
import Test.LambdaBuffers.Compiler.Gen.Utils (pick)
10-
import Test.QuickCheck qualified as QC
1112
import Test.Tasty (TestName)
1213
import Test.Tasty.HUnit (Assertion, HasCallStack, assertFailure)
1314

1415
data Mutation = MkMutation
1516
{ mutLabel :: TestName
16-
, mutFn :: CompilerInput -> QC.Gen (CompilerInput, CompilerOutput -> Assertion)
17+
, mutFn :: CompilerInput -> H.Gen (CompilerInput, CompilerOutput -> Assertion)
1718
}
1819

1920
instance Show Mutation where
2021
show :: Mutation -> String
2122
show = show . mutLabel
2223

24+
-- | Benign mutations
2325
shuffleModules :: Mutation
24-
shuffleModules = MkMutation "Shuffle modules benign mutation" $ \compInp -> do
25-
shuffled <- QC.shuffle (compInp ^. modules)
26+
shuffleModules = MkMutation "Shuffling modules inside of the CompilerInput should not affect compilation" $ \compInp -> do
27+
shuffled <- H.shuffle (compInp ^. modules)
2628
return
2729
( compInp & modules .~ shuffled
2830
, compilerResOrFail (\_ -> return ())
2931
)
3032

3133
shuffleTyDefs :: Mutation
32-
shuffleTyDefs = MkMutation "Shuffle type definitions benign mutation" $ \compInp -> do
34+
shuffleTyDefs = MkMutation "Shuffling type definitions inside of the Module should not affect compilation" $ \compInp -> do
3335
case nonEmpty $ compInp ^. modules of
3436
Nothing ->
3537
return
@@ -38,7 +40,7 @@ shuffleTyDefs = MkMutation "Shuffle type definitions benign mutation" $ \compInp
3840
)
3941
Just ms -> do
4042
(m, ms') <- pick ms
41-
shuffled <- QC.shuffle (m ^. typeDefs)
43+
shuffled <- H.shuffle (m ^. typeDefs)
4244
let m' = m & typeDefs .~ shuffled
4345
return
4446
( compInp & modules .~ m' : ms'

0 commit comments

Comments
 (0)