@@ -54,33 +54,38 @@ instance Arbitrary Pattern where
5454 PLiteral l -> PLiteral <$> shrink l
5555 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
5656 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
57− where shrinkWHead (x:xs) = (x:) <$> shrink xs
5857
59−isValidType :: Type -> Bool
60−isValidType (Lambda s t) = isValidType s && isValidType t
61−isValidType (Record [] (Just _)) = False
62−isValidType (Record (("",_):_) _) = False
63−isValidType (Record fs _) = all isValidType $ map snd fs
64−isValidType (Data _ []) = False
65−isValidType (Data _ ts) = all isValidType ts
66−isValidType _ = True
58+shrinkWHead :: Arbitrary a => [a] -> [[a]]
59+shrinkWHead [] = error "Should be nonempty"
60+shrinkWHead (x:xs) = (x:) <$> shrink xs
6761
6862instance Arbitrary Type where
69− arbitrary = sized tipe `suchThat` isValidType
63+ arbitrary = sized tipe
7064 where tipe :: Int -> Gen Type
7165 tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
7266 , Var <$> lowVar
73− , Data <$> capVar <*> listOf1 depthTipe
74− , Record <$> listOf ((,) <$> lowVar <*> depthTipe) <*> maybeOf lowVar
67+ , Data <$> capVar <*> listOf depthTipe
68+ , Record <$> listOf1 field <*> (Just <$> lowVar)
69+ , Record <$> listOf field <*> pure Nothing
7570 ]
7671 where depthTipe :: Gen Type
77− depthTipe = choose (0,n) >>= tipe
72+ depthTipe = do
73+ m <- choose (0,n)
74+ tipe m
75+ field :: Gen (String, Type)
76+ field = (,) <$> lowVar <*> depthTipe
7877
79− shrink tipe = filter isValidType $ case tipe of
78+ shrink tipe = case tipe of
8079 Lambda s t -> Lambda <$> shrink s <*> shrink t
8180 Var _ -> []
82− Data n ts -> Data n <$> shrink ts
83− Record fs t -> Record <$> shrink fs <*> pure t
81+ Data n ts -> Data <$> shrinkWHead n <*> shrink ts
82+ Record fs t -> case t of
83+ Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
84+ Just _ ->
85+ do
86+ fields <- filter (not . null) $ shrinkList shrinkField fs
87+ return $ Record fields t
88+ where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
8489
8590lowVar :: Gen String
8691lowVar = notReserved $ (:) <$> lower <*> listOf varLetter