@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# OPTIONS_GHC -W -fno-warn-orphans #-}
2module Tests.Property.Arbitrary where
2module Tests.Property.Arbitrary where
4import Control.Applicative ((<$>), (<*>), pure)
4import Control.Applicative ((<$>), (<*>), pure)
@@ -10,6 +10,7 @@ import qualified Parse.Helpers (reserveds)
11import SourceSyntax.Literal
11import SourceSyntax.Literal
12import SourceSyntax.Pattern
12import SourceSyntax.Pattern
13+import SourceSyntax.Type hiding (listOf)
14instance Arbitrary Literal where
15instance Arbitrary Literal where
15 arbitrary = oneof [ IntNum <$> arbitrary
16 arbitrary = oneof [ IntNum <$> arbitrary
@@ -55,6 +56,23 @@ instance Arbitrary Pattern where
55 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56 where shrinkWHead (x:xs) = (x:) <$> shrink xs
57 where shrinkWHead (x:xs) = (x:) <$> shrink xs
59+instance Arbitrary Type where
60+ arbitrary = sized tipe
61+ where tipe :: Int -> Gen Type
62+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
64+ , Data <$> arbitrary <*> listOf1 depthTipe
65+ , Record <$> listOf ((,) <$> arbitrary <*> depthTipe) <*> arbitrary
67+ where depthTipe :: Gen Type
68+ depthTipe = choose (0,n) >>= tipe
70+ shrink tipe = case tipe of
71+ Lambda s t -> Lambda <$> shrink s <*> shrink t
73+ Data n ts -> Data n <$> shrink ts
74+ Record fs t -> Record <$> shrink fs <*> pure t
58lowVar :: Gen String
76lowVar :: Gen String
59lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
77lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
60 where lower = elements ['a'..'z']
78 where lower = elements ['a'..'z']