git.iko.soy/elk
on master help sign in
Merge pull request #452 from johnpmayer/arbitary-tipe
0026466Evan Czaplicki
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.hs+7−4
@@ -7,22 +7,25 @@ import Test.Framework.Providers.QuickCheck2
7import Test.HUnit (assert)
7import Test.HUnit (assert)
8import Test.QuickCheck
8import Test.QuickCheck
9import Text.Parsec.Combinator (eof)
9import Text.Parsec.Combinator (eof)
10+import Text.PrettyPrint as P
10
11
11import SourceSyntax.Literal as Lit
12import SourceSyntax.Literal as Lit
12import SourceSyntax.Pattern as Pat
13import SourceSyntax.Pattern as Pat
13import SourceSyntax.PrettyPrint (Pretty, pretty)
14import SourceSyntax.PrettyPrint (Pretty, pretty)
14import Parse.Helpers (IParser, iParse)
15import Parse.Helpers (IParser, iParse)
15import Parse.Literal (literal)
16import Parse.Literal (literal)
16−import Parse.Pattern (expr)
17+import qualified Parse.Pattern as Pat (expr)
18+import qualified Parse.Type as Type (expr)
17import Tests.Property.Arbitrary
19import Tests.Property.Arbitrary
18
20
19propertyTests :: Test
21propertyTests :: Test
20propertyTests =
22propertyTests =
21 testGroup "Parse/Print Agreement Tests"
23 testGroup "Parse/Print Agreement Tests"
22 [
24 [
23− testCase "Long Pattern test" $ assert (prop_parse_print expr longPat)
25+ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)
24 , testProperty "Literal test" $ prop_parse_print literal
26 , testProperty "Literal test" $ prop_parse_print literal
25− , testProperty "Pattern test" $ prop_parse_print expr
27+ , testProperty "Pattern test" $ prop_parse_print Pat.expr
28+ , testProperty "Type test" $ prop_parse_print Type.expr
26 ]
29 ]
27
30
28 where
31 where
@@ -48,4 +51,4 @@ prop_parse_print p x =
48 either (const False) (== x) . parse_print p $ x
51 either (const False) (== x) . parse_print p $ x
49
52
50parse_print :: (Pretty a) => IParser a -> a -> Either String a
53parse_print :: (Pretty a) => IParser a -> a -> Either String a
51−parse_print p = either (Left . show) (Right) . iParse (p <* eof) . show . pretty
54+parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
tests/Tests/Property/Arbitrary.hs+42−4
@@ -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
3
3
4import Control.Applicative ((<$>), (<*>), pure)
4import Control.Applicative ((<$>), (<*>), pure)
@@ -10,6 +10,7 @@ import qualified Parse.Helpers (reserveds)
10
10
11import SourceSyntax.Literal
11import SourceSyntax.Literal
12import SourceSyntax.Pattern
12import SourceSyntax.Pattern
13+import SourceSyntax.Type hiding (listOf)
13
14
14instance Arbitrary Literal where
15instance Arbitrary Literal where
15 arbitrary = oneof [ IntNum <$> arbitrary
16 arbitrary = oneof [ IntNum <$> arbitrary
@@ -43,8 +44,8 @@ instance Arbitrary Pattern where
43 ]
44 ]
44 where sizedPats = do
45 where sizedPats = do
45 len <- choose (0,n)
46 len <- choose (0,n)
46− let m = n `div` len in
47+ let m = n `div` (len + 1)
47− vectorOf len $ pat m
48+ vectorOf len $ pat m
48
49
49 shrink pat = case pat of
50 shrink pat = case pat of
50 PAnything -> []
51 PAnything -> []
@@ -53,7 +54,44 @@ instance Arbitrary Pattern where
53 PLiteral l -> PLiteral <$> shrink l
54 PLiteral l -> PLiteral <$> shrink l
54 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
55 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
55 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
57+
58+shrinkWHead :: Arbitrary a => [a] -> [[a]]
59+shrinkWHead [] = error "Should be nonempty"
56− where shrinkWHead (x:xs) = (x:) <$> shrink xs
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
57
95
58lowVar :: Gen String
96lowVar :: Gen String
59lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
97lowVar = notReserved $ (:) <$> lower <*> listOf varLetter