Skip to content

Commit 650f57a

Browse files
bladyjokerbladyjoker
committed
Added benign mutation tests
1 parent 8a1cfe6 commit 650f57a

File tree

7 files changed

+193
-84
lines changed

7 files changed

+193
-84
lines changed

‎lambda-buffers-compiler/app/LambdaBuffers/Compiler/Cli/Compile.hs‎

Lines changed: 9 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,14 @@
11
module LambdaBuffers.Compiler.Cli.Compile (CompileOpts (..), compile) where
22

3-
import Control.Lens (makeLenses, (&), (.~))
4-
import Control.Lens.Getter ((^.))
3+
import Control.Lens (makeLenses, (^.))
54
import Data.ByteString qualified as BS
6-
import Data.ProtoLens (Message (defMessage))
75
import Data.ProtoLens qualified as Pb
86
import Data.ProtoLens.TextFormat qualified as PbText
97
import Data.Text.Lazy qualified as Text
108
import Data.Text.Lazy.IO qualified as Text
119
import LambdaBuffers.Compiler (runCompiler)
12-
import Proto.Compiler (CompilerError, CompilerInput, CompilerOutput)
13-
import Proto.Compiler_Fields (compilerError, compilerResult)
10+
import Proto.Compiler (CompilerInput, CompilerOutput)
11+
import Proto.Compiler_Fields (maybe'compilerError)
1412
import System.FilePath.Lens (extension)
1513

1614
data CompileOpts = CompileOpts
@@ -27,14 +25,13 @@ makeLenses ''CompileOpts
2725
compile :: CompileOpts -> IO ()
2826
compile opts = do
2927
compInp <- readCompilerInput (opts ^. input)
30-
case runCompiler compInp of
31-
Left compErr -> do
32-
putStrLn "Encountered errors during Compilation"
33-
writeCompilerError (opts ^. output) compErr
34-
Right compRes -> do
28+
let compOut = runCompiler compInp
29+
case compOut ^. maybe'compilerError of
30+
Nothing -> do
3531
putStrLn "Compilation succeeded"
36-
writeCompilerOutput (opts ^. output) (defMessage & compilerResult .~ compRes)
37-
return ()
32+
Just _ -> do
33+
putStrLn "Compilation failed"
34+
writeCompilerOutput (opts ^. output) compOut
3835

3936
readCompilerInput :: FilePath -> IO CompilerInput
4037
readCompilerInput fp = do
@@ -48,9 +45,6 @@ readCompilerInput fp = do
4845
return $ PbText.readMessageOrDie content
4946
_ -> error $ "Unknown CompilerInput format " <> ext
5047

51-
writeCompilerError :: FilePath -> CompilerError -> IO ()
52-
writeCompilerError fp err = writeCompilerOutput fp (defMessage & compilerError .~ err)
53-
5448
writeCompilerOutput :: FilePath -> CompilerOutput -> IO ()
5549
writeCompilerOutput fp cr = do
5650
let ext = fp ^. extension

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -171,6 +171,8 @@ test-suite tests
171171
Test.KindCheck.Errors
172172
Test.LambdaBuffers.Compiler
173173
Test.LambdaBuffers.Compiler.Gen
174+
Test.LambdaBuffers.Compiler.Gen.Mutation
175+
Test.LambdaBuffers.Compiler.Gen.Utils
174176
Test.TypeClassCheck
175177
Test.Utils.CompilerInput
176178
Test.Utils.Constructors

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,17 @@
11
module LambdaBuffers.Compiler (runCompiler) where
22

3+
import Control.Lens ((&), (.~))
34
import Data.ProtoLens (Message (defMessage))
4-
import LambdaBuffers.Compiler.KindCheck (check_)
5+
import LambdaBuffers.Compiler.KindCheck qualified as KindCheck
56
import LambdaBuffers.Compiler.ProtoCompat.FromProto (
67
runFromProto,
78
toProto,
89
)
9-
import Proto.Compiler (CompilerError, CompilerInput, CompilerResult)
10+
import Proto.Compiler (CompilerInput, CompilerOutput)
11+
import Proto.Compiler_Fields qualified as P
1012

11-
runCompiler :: CompilerInput -> Either CompilerError CompilerResult
13+
runCompiler :: CompilerInput -> CompilerOutput
1214
runCompiler compInp = do
13-
compInp' <- runFromProto compInp
14-
case check_ compInp' of
15-
Left err -> Left $ toProto err
16-
Right _ -> Right defMessage
15+
case runFromProto compInp of
16+
Left err -> defMessage & P.compilerError .~ err
17+
Right compInp' -> toProto $ KindCheck.check compInp'

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

Lines changed: 35 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,14 @@
11
module Test.LambdaBuffers.Compiler (test) where
22

3+
import Control.Lens ((&), (.~))
34
import Data.ProtoLens (Message (defMessage))
45
import LambdaBuffers.Compiler (runCompiler)
6+
import Proto.Compiler (CompilerOutput)
7+
import Proto.Compiler_Fields (compilerResult)
58
import Test.LambdaBuffers.Compiler.Gen (genCompilerInput)
6-
import Test.QuickCheck (forAll, (===))
9+
import Test.LambdaBuffers.Compiler.Gen.Mutation qualified as Mut
10+
import Test.QuickCheck (forAll, forAllBlind)
11+
import Test.QuickCheck qualified as QC
712
import Test.Tasty (TestTree, testGroup)
813
import Test.Tasty.QuickCheck (testProperty)
914

@@ -12,10 +17,37 @@ test =
1217
testGroup
1318
"Compiler Proto API tests"
1419
[ allCorrectCompInpCompile
20+
, allCorrectCompInpCompileAfterBenignMut
1521
]
1622

23+
compilationOk :: CompilerOutput -> Bool
24+
compilationOk compOut = compOut == (defMessage & compilerResult .~ defMessage)
25+
1726
allCorrectCompInpCompile :: TestTree
18-
allCorrectCompInpCompile = testProperty "All correct CompilerInputs must compile" (forAll genCompilerInput (\compInp -> runCompiler compInp === Right defMessage))
27+
allCorrectCompInpCompile = testProperty "All correct CompilerInputs must compile" (forAll genCompilerInput (compilationOk . runCompiler))
28+
29+
allCorrectCompInpCompileAfterBenignMut :: TestTree
30+
allCorrectCompInpCompileAfterBenignMut =
31+
testProperty
32+
"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+
)
1952

2053
-- TODO(bladyjoker): Add error producing mutations.
21-
-- TODO(bladyjoker): Add bening mutations (module, tydef, classdef shuffle).

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

Lines changed: 1 addition & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,6 @@ import Data.Foldable (Foldable (toList))
77
import Data.List.NonEmpty (NonEmpty ((:|)))
88
import Data.Map (Map)
99
import Data.Map qualified as Map
10-
import Data.Map.NonEmpty (NEMap)
11-
import Data.Map.NonEmpty qualified as NEMap
1210
import Data.ProtoLens (Message (defMessage))
1311
import Data.ProtoLens.Field (HasField)
1412
import Data.Set (Set)
@@ -22,6 +20,7 @@ import GHC.Enum qualified as Int
2220
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)
2321
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)
2422
import Proto.Compiler_Fields qualified as P
23+
import Test.LambdaBuffers.Compiler.Gen.Utils (distribute, indexBy, nesetOf, setOf, vecOf)
2524
import Test.QuickCheck qualified as QC (arbitraryPrintableChar)
2625
import Test.QuickCheck.Gen qualified as QC
2726

@@ -231,48 +230,6 @@ genCompilerInput = do
231230
return $ defMessage & modules .~ toList ms
232231

233232
-- | Utils
234-
235-
-- | Distributes values (first argument) over the keys (second) randomly.
236-
distribute :: Foldable t => Ord k => t v -> Set k -> QC.Gen (Map k (NonEmpty v))
237-
distribute vals keys = do
238-
(leftover, distributed) <- distributeSingle vals keys
239-
if null leftover
240-
then return distributed
241-
else do
242-
distributed' <- distribute leftover keys
243-
return $ Map.unionWith (<>) distributed distributed'
244-
245-
distributeSingle :: Foldable t => Ord k => t v -> Set k -> QC.Gen ([v], Map k (NonEmpty v))
246-
distributeSingle vals =
247-
foldM
248-
( \(vals', dist) key ->
249-
case vals' of
250-
[] -> return (vals', dist)
251-
(v : vals'') -> do
252-
(chosenVals, leftoverVals) <- partition vals''
253-
return (leftoverVals, Map.insert key (v :| chosenVals) dist)
254-
)
255-
(toList vals, mempty)
256-
257-
-- | Partition a list randomly.
258-
partition :: forall {a}. [a] -> QC.Gen ([a], [a])
259-
partition xs = go xs []
260-
where
261-
go :: [a] -> [a] -> QC.Gen ([a], [a])
262-
go [] outs = return (outs, [])
263-
go (i : ins) outs = do
264-
b <- QC.chooseAny
265-
if b
266-
then go ins (i : outs)
267-
else return (outs, i : ins)
268-
269-
_indexBy :: Ord k => (a -> k) -> NonEmpty a -> NEMap k a
270-
_indexBy keyF (x :| xs) = foldl (\t x' -> NEMap.insert (keyF x') x' t) (NEMap.singleton (keyF x) x) xs
271-
272-
-- | Index a list given a key function.
273-
indexBy :: Foldable t => Ord k => (a -> k) -> t a -> Map k a
274-
indexBy keyF = foldl (\t x -> Map.insert (keyF x) x t) mempty
275-
276233
withSourceInfo :: HasField a "sourceInfo" SourceInfo => a -> QC.Gen a
277234
withSourceInfo msg = do
278235
f <- Text.pack <$> vecOf QC.arbitraryPrintableChar 10
@@ -286,18 +243,3 @@ withSourceInfo msg = do
286243
& sourceInfo . file .~ f
287244
& sourceInfo . posFrom .~ pos
288245
& sourceInfo . posTo .~ pos
289-
290-
vecOf :: forall {a}. QC.Gen a -> Int -> QC.Gen [a]
291-
vecOf = flip QC.vectorOf
292-
293-
nevecOf :: forall {a}. QC.Gen a -> Int -> QC.Gen (NonEmpty a)
294-
nevecOf g n =
295-
g >>= \x -> do
296-
xs <- QC.vectorOf (n - 1) g
297-
return $ x :| xs
298-
299-
nesetOf :: forall {a}. Ord a => QC.Gen a -> Int -> QC.Gen (NESet a)
300-
nesetOf g n = NESet.fromList <$> nevecOf g n
301-
302-
setOf :: forall {a}. Ord a => QC.Gen a -> Int -> QC.Gen (Set a)
303-
setOf g n = Set.fromList <$> vecOf g n

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

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
module Test.LambdaBuffers.Compiler.Gen.Mutation (shuffleModules, shuffleTyDefs, Mutation (..)) where
2+
3+
import Control.Lens ((&), (.~), (^.))
4+
import Data.List.NonEmpty (nonEmpty)
5+
import Data.ProtoLens (Message (messageName))
6+
import Data.Proxy (Proxy (Proxy))
7+
import Proto.Compiler (CompilerError, CompilerInput, CompilerOutput, CompilerOutput'CompilerOutput (CompilerOutput'CompilerError, CompilerOutput'CompilerResult), CompilerResult)
8+
import Proto.Compiler_Fields (maybe'compilerOutput, modules, typeDefs)
9+
import Test.LambdaBuffers.Compiler.Gen.Utils (pick)
10+
import Test.QuickCheck qualified as QC
11+
import Test.Tasty (TestName)
12+
import Test.Tasty.HUnit (Assertion, HasCallStack, assertFailure)
13+
14+
data Mutation = MkMutation
15+
{ mutLabel :: TestName
16+
, mutFn :: CompilerInput -> QC.Gen (CompilerInput, CompilerOutput -> Assertion)
17+
}
18+
19+
instance Show Mutation where
20+
show :: Mutation -> String
21+
show = show . mutLabel
22+
23+
shuffleModules :: Mutation
24+
shuffleModules = MkMutation "Shuffle modules benign mutation" $ \compInp -> do
25+
shuffled <- QC.shuffle (compInp ^. modules)
26+
return
27+
( compInp & modules .~ shuffled
28+
, compilerResOrFail (\_ -> return ())
29+
)
30+
31+
shuffleTyDefs :: Mutation
32+
shuffleTyDefs = MkMutation "Shuffle type definitions benign mutation" $ \compInp -> do
33+
case nonEmpty $ compInp ^. modules of
34+
Nothing ->
35+
return
36+
( compInp
37+
, compilerResOrFail (\_ -> return ())
38+
)
39+
Just ms -> do
40+
(m, ms') <- pick ms
41+
shuffled <- QC.shuffle (m ^. typeDefs)
42+
let m' = m & typeDefs .~ shuffled
43+
return
44+
( compInp & modules .~ m' : ms'
45+
, compilerResOrFail (\_ -> return ())
46+
)
47+
48+
-- | Utils
49+
compilerOut :: HasCallStack => (CompilerError -> Assertion) -> (CompilerResult -> Assertion) -> CompilerOutput -> Assertion
50+
compilerOut err res co = case co ^. maybe'compilerOutput of
51+
Nothing -> assertFailure $ "compiler_output field must be set in " <> show (messageName (Proxy @CompilerOutput))
52+
Just (CompilerOutput'CompilerError cerr) -> err cerr
53+
Just (CompilerOutput'CompilerResult cres) -> res cres
54+
55+
compilerResOrFail :: HasCallStack => (CompilerResult -> Assertion) -> CompilerOutput -> Assertion
56+
compilerResOrFail = compilerOut (\cerr -> assertFailure $ "Expected to succeed but failed with " <> show cerr)

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

Lines changed: 82 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,82 @@
1+
module Test.LambdaBuffers.Compiler.Gen.Utils (distribute, partition, indexBy, vecOf, nevecOf, setOf, nesetOf, pick) where
2+
3+
import Control.Monad (foldM)
4+
import Data.Foldable (Foldable (toList))
5+
import Data.List.NonEmpty (NonEmpty ((:|)))
6+
import Data.Map (Map)
7+
import Data.Map qualified as Map
8+
import Data.Map.NonEmpty (NEMap)
9+
import Data.Map.NonEmpty qualified as NEMap
10+
import Data.Set (Set)
11+
import Data.Set qualified as Set
12+
import Data.Set.NonEmpty (NESet)
13+
import Data.Set.NonEmpty qualified as NESet
14+
import Test.QuickCheck.Gen qualified as QC
15+
16+
-- | Distributes values (first argument) over the keys (second) randomly.
17+
distribute :: Foldable t => Ord k => t v -> Set k -> QC.Gen (Map k (NonEmpty v))
18+
distribute vals keys = do
19+
(leftover, distributed) <- distributeSingle vals keys
20+
if null leftover
21+
then return distributed
22+
else do
23+
distributed' <- distribute leftover keys
24+
return $ Map.unionWith (<>) distributed distributed'
25+
26+
distributeSingle :: Foldable t => Ord k => t v -> Set k -> QC.Gen ([v], Map k (NonEmpty v))
27+
distributeSingle vals =
28+
foldM
29+
( \(vals', dist) key ->
30+
case vals' of
31+
[] -> return (vals', dist)
32+
(v : vals'') -> do
33+
(chosenVals, leftoverVals) <- partition vals''
34+
return (leftoverVals, Map.insert key (v :| chosenVals) dist)
35+
)
36+
(toList vals, mempty)
37+
38+
-- | Partition a list randomly.
39+
partition :: forall {a}. [a] -> QC.Gen ([a], [a])
40+
partition xs = go xs []
41+
where
42+
go :: [a] -> [a] -> QC.Gen ([a], [a])
43+
go [] outs = return (outs, [])
44+
go (i : ins) outs = do
45+
b <- QC.chooseAny
46+
if b
47+
then go ins (i : outs)
48+
else return (outs, i : ins)
49+
50+
-- | Pick an element randomly.
51+
pick :: forall {a}. NonEmpty a -> QC.Gen (a, [a])
52+
pick (x :| xs) = go x xs []
53+
where
54+
go :: t -> [t] -> [t] -> QC.Gen (t, [t])
55+
go champion [] losers = return (champion, losers)
56+
go champion (challenger : challengers) losers = do
57+
championWins <- QC.chooseAny
58+
if championWins
59+
then go champion challengers (challenger : losers)
60+
else go challenger challengers (champion : losers)
61+
62+
_indexBy :: Ord k => (a -> k) -> NonEmpty a -> NEMap k a
63+
_indexBy keyF (x :| xs) = foldl (\t x' -> NEMap.insert (keyF x') x' t) (NEMap.singleton (keyF x) x) xs
64+
65+
-- | Index a list given a key function.
66+
indexBy :: Foldable t => Ord k => (a -> k) -> t a -> Map k a
67+
indexBy keyF = foldl (\t x -> Map.insert (keyF x) x t) mempty
68+
69+
vecOf :: forall {a}. QC.Gen a -> Int -> QC.Gen [a]
70+
vecOf = flip QC.vectorOf
71+
72+
nevecOf :: forall {a}. QC.Gen a -> Int -> QC.Gen (NonEmpty a)
73+
nevecOf g n =
74+
g >>= \x -> do
75+
xs <- QC.vectorOf (n - 1) g
76+
return $ x :| xs
77+
78+
nesetOf :: forall {a}. Ord a => QC.Gen a -> Int -> QC.Gen (NESet a)
79+
nesetOf g n = NESet.fromList <$> nevecOf g n
80+
81+
setOf :: forall {a}. Ord a => QC.Gen a -> Int -> QC.Gen (Set a)
82+
setOf g n = Set.fromList <$> vecOf g n

0 commit comments

Comments
 (0)