@@ -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
@@ -43,8 +44,8 @@ instance Arbitrary Pattern where
4344 ]
4445 where sizedPats = do
4546 len <- choose (0,n)
46− let m = n `div` len in
47− vectorOf len $ pat m
47+ let m = n `div` (len + 1)
48+ vectorOf len $ pat m
4849
4950 shrink pat = case pat of
5051 PAnything -> []
@@ -53,7 +54,44 @@ instance Arbitrary Pattern where
5354 PLiteral l -> PLiteral <$> shrink l
5455 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
5556 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56− where shrinkWHead (x:xs) = (x:) <$> shrink xs
57+
58+shrinkWHead :: Arbitrary a => [a] -> [[a]]
59+shrinkWHead [] = error "Should be nonempty"
60+shrinkWHead (x:xs) = (x:) <$> shrink xs
61+
62+instance Arbitrary Type where
63+ arbitrary = sized tipe
64+ where tipe :: Int -> Gen Type
65+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
66+ , Var <$> lowVar
67+ , Data <$> capVar <*> depthTipes
68+ , Record <$> fields <*> pure Nothing
69+ , Record <$> fields1 <*> (Just <$> lowVar)
70+ ]
71+ where depthTipe = choose (0,n) >>= tipe
72+ depthTipes = do
73+ len <- choose (0,n)
74+ let m = n `div` (len + 1)
75+ vectorOf len $ tipe m
76+
77+ field = (,) <$> lowVar <*> depthTipe
78+ fields = do
79+ len <- choose (0,n)
80+ let m = n `div` (len + 1)
81+ vectorOf len $ (,) <$> lowVar <*> tipe m
82+ fields1 = (:) <$> field <*> fields
83+
84+ shrink tipe = case tipe of
85+ Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
86+ Var _ -> []
87+ Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
88+ Record fs t -> map snd fs ++ case t of
89+ Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
90+ Just _ ->
91+ do
92+ fields <- filter (not . null) $ shrinkList shrinkField fs
93+ return $ Record fields t
94+ where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
5795
5896lowVar :: Gen String
5997lowVar = notReserved $ (:) <$> lower <*> listOf varLetter