@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# OPTIONS_GHC -W -fno-warn-orphans #-}
22module Tests.Property.Arbitrary where
33
44import Control.Applicative ((<$>), (<*>), pure)
@@ -10,6 +10,7 @@ import qualified Parse.Helpers (reserveds)
1010
1111import SourceSyntax.Literal
1212import SourceSyntax.Pattern
13+import SourceSyntax.Type hiding (listOf)
1314
1415instance Arbitrary Literal where
1516 arbitrary = oneof [ IntNum <$> arbitrary
@@ -55,6 +56,23 @@ instance Arbitrary Pattern where
5556 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
5657 where shrinkWHead (x:xs) = (x:) <$> shrink xs
5758
59+instance Arbitrary Type where
60+ arbitrary = sized tipe
61+ where tipe :: Int -> Gen Type
62+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
63+ , Var <$> arbitrary
64+ , Data <$> arbitrary <*> listOf1 depthTipe
65+ , Record <$> listOf ((,) <$> arbitrary <*> depthTipe) <*> arbitrary
66+ ]
67+ where depthTipe :: Gen Type
68+ depthTipe = choose (0,n) >>= tipe
69+
70+ shrink tipe = case tipe of
71+ Lambda s t -> Lambda <$> shrink s <*> shrink t
72+ Var _ -> []
73+ Data n ts -> Data n <$> shrink ts
74+ Record fs t -> Record <$> shrink fs <*> pure t
75+
5876lowVar :: Gen String
5977lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
6078 where lower = elements ['a'..'z']