github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-26 00:12:29 +03:00
Code Issues Projects Releases Wiki Activity

Bound depth by the cube root of the size parameter, and length by the square root.

Browse Source
This commit is contained in:
Rob Rix 2015-12-11 15:41:35 -05:00
parent d9bb395f2c
commit 9ece0af975
1 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
test/Spec.hs
View File

@ -26,14 +26,14 @@ unTerm arbitraryTerm = unfold unpack arbitraryTerm
where unpack (ArbitraryTerm (annotation, syntax)) = (annotation, syntax) where unpack (ArbitraryTerm (annotation, syntax)) = (annotation, syntax)
instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where
arbitrary = sized boundedTerm arbitrary = sized (\ x -> boundedTerm x x) -- first indicates the square of the max length of lists, second indicates the cube of the max depth of the tree
where boundedTerm n = ArbitraryTerm <$> ((,) <$> arbitrary <*> boundedSyntax n) where boundedTerm m n = ArbitraryTerm <$> ((,) <$> arbitrary <*> boundedSyntax m n)
boundedSyntax 0 = liftM Leaf arbitrary boundedSyntax _ n | n <= 0 = liftM Leaf arbitrary
boundedSyntax _ = frequency boundedSyntax m n = frequency
[ (1, liftM Leaf arbitrary), [ (4, liftM Leaf arbitrary),
(4, liftM Indexed $ listOf arbitrary), (1, liftM Indexed $ take n <$> listOf (boundedTerm (div m 2) (div n 3))),
(4, liftM Fixed $ listOf arbitrary), (1, liftM Fixed $ take n <$> listOf (boundedTerm (div m 2) (div n 3))) ]
(4, liftM (Keyed . Map.fromList) $ listOf arbitrary) ] -- (4, liftM (Keyed . Map.fromList) $ listOf arbitrary) ]
shrink term@(ArbitraryTerm (annotation, syntax)) = (++) (subterms term) $ filter (/= term) $ shrink term@(ArbitraryTerm (annotation, syntax)) = (++) (subterms term) $ filter (/= term) $
ArbitraryTerm <$> ((,) <$> shrink annotation <*> case syntax of ArbitraryTerm <$> ((,) <$> shrink annotation <*> case syntax of
Leaf a -> Leaf <$> shrink a Leaf a -> Leaf <$> shrink a