diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs index f51b2ca..ee8d416 100644 --- a/tests/Tests/Property.hs +++ b/tests/Tests/Property.hs @@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof) import Text.PrettyPrint as P import SourceSyntax.Literal as Lit -import SourceSyntax.Pattern as Pat +import qualified SourceSyntax.Pattern as P import SourceSyntax.PrettyPrint (Pretty, pretty) import Parse.Helpers (IParser, iParse) import Parse.Literal (literal) @@ -31,24 +31,25 @@ propertyTests = where -- This test was autogenerated from the Pattern test and should be -- left in all its ugly glory. - longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+') - , Pat.PRecord [ - "q7yclkcm7k_ikstrczv_" - , "wQRv6gKsvvkjw4b5F" - ,"c9'eFfhk9FTvsMnwF_D" - ,"yqxhEkHvRFwZ" - ,"o" - ,"nbUlCn3y3NnkVoxhW" - ,"iJ0MNy3KZ_lrs" - ,"ug" - ,"sHHsX" - ,"mRKs9d" - ,"o2KiCX5'ZRzHJfRi8" ] - , Pat.PVar "su'BrrbPUK6I33Eq" ] + longPat = P.Data "I" [ P.Literal (Lit.Chr '+') + , P.Record + [ "q7yclkcm7k_ikstrczv_" + , "wQRv6gKsvvkjw4b5F" + ,"c9'eFfhk9FTvsMnwF_D" + ,"yqxhEkHvRFwZ" + ,"o" + ,"nbUlCn3y3NnkVoxhW" + ,"iJ0MNy3KZ_lrs" + ,"ug" + ,"sHHsX" + ,"mRKs9d" + ,"o2KiCX5'ZRzHJfRi8" ] + , P.Var "su'BrrbPUK6I33Eq" + ] prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool prop_parse_print p x = either (const False) (== x) . parse_print p $ x parse_print :: (Pretty a) => IParser a -> a -> Either String a -parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty +parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs index f58b5c7..7fc4455 100644 --- a/tests/Tests/Property/Arbitrary.hs +++ b/tests/Tests/Property/Arbitrary.hs @@ -8,98 +8,112 @@ import Test.QuickCheck.Gen import qualified Data.Set as Set import qualified Parse.Helpers (reserveds) -import SourceSyntax.Literal -import SourceSyntax.Pattern -import SourceSyntax.Type hiding (listOf) +import qualified SourceSyntax.Literal as L +import qualified SourceSyntax.Pattern as P +import qualified SourceSyntax.Type as T -instance Arbitrary Literal where - arbitrary = oneof [ IntNum <$> arbitrary - , FloatNum <$> (arbitrary `suchThat` noE) - , Chr <$> arbitrary - -- This is too permissive - , Str <$> arbitrary - -- Booleans aren't actually source syntax - -- , Boolean <$> arbitrary - ] - shrink l = case l of - IntNum n -> IntNum <$> shrink n - FloatNum f -> FloatNum <$> (filter noE . shrink $ f) - Chr c -> Chr <$> shrink c - Str s -> Str <$> shrink s - Boolean b -> Boolean <$> shrink b +instance Arbitrary L.Literal where + arbitrary = + oneof + [ L.IntNum <$> arbitrary + , L.FloatNum <$> (arbitrary `suchThat` noE) + , L.Chr <$> arbitrary + -- This is too permissive + , L.Str <$> arbitrary + -- Booleans aren't actually source syntax + -- , Boolean <$> arbitrary + ] + + shrink lit = + case lit of + L.IntNum n -> L.IntNum <$> shrink n + L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f) + L.Chr c -> L.Chr <$> shrink c + L.Str s -> L.Str <$> shrink s + L.Boolean b -> L.Boolean <$> shrink b noE :: Double -> Bool noE = notElem 'e' . show +genVector :: Int -> (Int -> Gen a) -> Gen [a] +genVector n generator = do + len <- choose (0,n) + let m = n `div` (len + 1) + vectorOf len $ generator m -instance Arbitrary Pattern where +instance Arbitrary P.Pattern where arbitrary = sized pat - where pat :: Int -> Gen Pattern - pat n = oneof [ pure PAnything - , PVar <$> lowVar - , PRecord <$> (listOf1 lowVar) - , PLiteral <$> arbitrary - , PAlias <$> lowVar <*> pat (n-1) - , PData <$> capVar <*> sizedPats - ] - where sizedPats = do - len <- choose (0,n) - let m = n `div` (len + 1) - vectorOf len $ pat m + where + pat :: Int -> Gen P.Pattern + pat n = + oneof + [ pure P.Anything + , P.Var <$> lowVar + , P.Record <$> (listOf1 lowVar) + , P.Literal <$> arbitrary + , P.Alias <$> lowVar <*> pat (n-1) + , P.Data <$> capVar <*> genVector n pat + ] - shrink pat = case pat of - PAnything -> [] - PVar v -> PVar <$> shrinkWHead v - PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs) - PLiteral l -> PLiteral <$> shrink l - PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p) - PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps) + shrink pat = + case pat of + P.Anything -> [] + P.Var v -> P.Var <$> shrinkWHead v + P.Literal l -> P.Literal <$> shrink l + P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p) + P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps) + P.Record fs -> + P.Record <$> filter (all notNull) (filter notNull (shrink fs)) + where + notNull = not . null shrinkWHead :: Arbitrary a => [a] -> [[a]] shrinkWHead [] = error "Should be nonempty" shrinkWHead (x:xs) = (x:) <$> shrink xs -instance Arbitrary Type where +instance Arbitrary T.Type where arbitrary = sized tipe - where tipe :: Int -> Gen Type - tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe - , Var <$> lowVar - , Data <$> capVar <*> depthTipes - , Record <$> fields <*> pure Nothing - , Record <$> fields1 <*> (Just <$> lowVar) - ] - where depthTipe = choose (0,n) >>= tipe - depthTipes = do - len <- choose (0,n) - let m = n `div` (len + 1) - vectorOf len $ tipe m + where + tipe :: Int -> Gen T.Type + tipe n = + let depthTipe = tipe =<< choose (0,n) + field = (,) <$> lowVar <*> depthTipe + fields = genVector n (\m -> (,) <$> lowVar <*> tipe m) + fields1 = (:) <$> field <*> fields + in + oneof + [ T.Lambda <$> depthTipe <*> depthTipe + , T.Var <$> lowVar + , T.Data <$> capVar <*> genVector n tipe + , T.Record <$> fields <*> pure Nothing + , T.Record <$> fields1 <*> (Just <$> lowVar) + ] - field = (,) <$> lowVar <*> depthTipe - fields = do - len <- choose (0,n) - let m = n `div` (len + 1) - vectorOf len $ (,) <$> lowVar <*> tipe m - fields1 = (:) <$> field <*> fields + shrink tipe = + case tipe of + T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t) + T.Var _ -> [] + T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts) + T.Record fs t -> map snd fs ++ record + where + record = + case t of + Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing + Just _ -> + do fields <- filter (not . null) $ shrinkList shrinkField fs + return $ T.Record fields t - shrink tipe = case tipe of - Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t) - Var _ -> [] - Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts) - Record fs t -> map snd fs ++ case t of - Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing - Just _ -> - do - fields <- filter (not . null) $ shrinkList shrinkField fs - return $ Record fields t - where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t + shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t lowVar :: Gen String lowVar = notReserved $ (:) <$> lower <*> listOf varLetter - where lower = elements ['a'..'z'] + where + lower = elements ['a'..'z'] capVar :: Gen String capVar = notReserved $ (:) <$> upper <*> listOf varLetter - where upper = elements ['A'..'Z'] + where + upper = elements ['A'..'Z'] varLetter :: Gen Char varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_'] @@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds exceptFor :: (Ord a) => Gen a -> [a] -> Gen a exceptFor g xs = g `suchThat` notAnX - where notAnX = flip Set.notMember xset - xset = Set.fromList xs + where + notAnX = flip Set.notMember xset + xset = Set.fromList xs