git.iko.soy/elk
on master help sign in
better gen and shrink, but stack overflows
afb6bd5John P Mayer Jr
compiler/SourceSyntax/Type.hs+3−1
compare with master
unifiedsplit
@@ -12,7 +12,7 @@ data Type = Lambda Type Type
12 | Var String
12 | Var String
13 | Data String [Type]
13 | Data String [Type]
14 | Record [(String,Type)] (Maybe String)
14 | Record [(String,Type)] (Maybe String)
15− deriving (Eq, Show)
15+ deriving (Eq)
16
16
17fieldMap :: [(String,a)] -> Map.Map String [a]
17fieldMap :: [(String,a)] -> Map.Map String [a]
18fieldMap fields =
18fieldMap fields =
@@ -27,6 +27,8 @@ listOf t = Data "_List" [t]
27tupleOf :: [Type] -> Type
27tupleOf :: [Type] -> Type
28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
29
29
30+instance Show Type where
31+ show = render . pretty
30
32
31instance Pretty Type where
33instance Pretty Type where
32 pretty tipe =
34 pretty tipe =
tests/Tests/Property/Arbitrary.hs+21−16
@@ -54,33 +54,38 @@ instance Arbitrary Pattern where
54 PLiteral l -> PLiteral <$> shrink l
54 PLiteral l -> PLiteral <$> shrink l
55 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
55 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
56 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
57− where shrinkWHead (x:xs) = (x:) <$> shrink xs
58
57
59−isValidType :: Type -> Bool
58+shrinkWHead :: Arbitrary a => [a] -> [[a]]
60−isValidType (Lambda s t) = isValidType s && isValidType t
59+shrinkWHead [] = error "Should be nonempty"
61−isValidType (Record [] (Just _)) = False
60+shrinkWHead (x:xs) = (x:) <$> shrink xs
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
67
61
68instance Arbitrary Type where
62instance Arbitrary Type where
69− arbitrary = sized tipe `suchThat` isValidType
63+ arbitrary = sized tipe
70 where tipe :: Int -> Gen Type
64 where tipe :: Int -> Gen Type
71 tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
65 tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
72 , Var <$> lowVar
66 , Var <$> lowVar
73− , Data <$> capVar <*> listOf1 depthTipe
67+ , Data <$> capVar <*> listOf depthTipe
74− , Record <$> listOf ((,) <$> lowVar <*> depthTipe) <*> maybeOf lowVar
68+ , Record <$> listOf1 field <*> (Just <$> lowVar)
69+ , Record <$> listOf field <*> pure Nothing
75 ]
70 ]
76 where depthTipe :: Gen Type
71 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
78
77
79− shrink tipe = filter isValidType $ case tipe of
78+ shrink tipe = case tipe of
80 Lambda s t -> Lambda <$> shrink s <*> shrink t
79 Lambda s t -> Lambda <$> shrink s <*> shrink t
81 Var _ -> []
80 Var _ -> []
82− Data n ts -> Data n <$> shrink ts
81+ Data n ts -> Data <$> shrinkWHead n <*> shrink ts
83− Record fs t -> Record <$> shrink fs <*> pure t
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
84
89
85lowVar :: Gen String
90lowVar :: Gen String
86lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
91lowVar = notReserved $ (:) <$> lower <*> listOf varLetter