Style changes and making things compatible with new Pattern constructor names
This commit is contained in:
parent
b2f3ff35dc
commit
5a80766051
2 changed files with 104 additions and 88 deletions
|
@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
|
||||||
import Text.PrettyPrint as P
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
import SourceSyntax.Literal as Lit
|
import SourceSyntax.Literal as Lit
|
||||||
import SourceSyntax.Pattern as Pat
|
import qualified SourceSyntax.Pattern as P
|
||||||
import SourceSyntax.PrettyPrint (Pretty, pretty)
|
import SourceSyntax.PrettyPrint (Pretty, pretty)
|
||||||
import Parse.Helpers (IParser, iParse)
|
import Parse.Helpers (IParser, iParse)
|
||||||
import Parse.Literal (literal)
|
import Parse.Literal (literal)
|
||||||
|
@ -31,24 +31,25 @@ propertyTests =
|
||||||
where
|
where
|
||||||
-- This test was autogenerated from the Pattern test and should be
|
-- This test was autogenerated from the Pattern test and should be
|
||||||
-- left in all its ugly glory.
|
-- left in all its ugly glory.
|
||||||
longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
|
longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
|
||||||
, Pat.PRecord [
|
, P.Record
|
||||||
"q7yclkcm7k_ikstrczv_"
|
[ "q7yclkcm7k_ikstrczv_"
|
||||||
, "wQRv6gKsvvkjw4b5F"
|
, "wQRv6gKsvvkjw4b5F"
|
||||||
,"c9'eFfhk9FTvsMnwF_D"
|
,"c9'eFfhk9FTvsMnwF_D"
|
||||||
,"yqxhEkHvRFwZ"
|
,"yqxhEkHvRFwZ"
|
||||||
,"o"
|
,"o"
|
||||||
,"nbUlCn3y3NnkVoxhW"
|
,"nbUlCn3y3NnkVoxhW"
|
||||||
,"iJ0MNy3KZ_lrs"
|
,"iJ0MNy3KZ_lrs"
|
||||||
,"ug"
|
,"ug"
|
||||||
,"sHHsX"
|
,"sHHsX"
|
||||||
,"mRKs9d"
|
,"mRKs9d"
|
||||||
,"o2KiCX5'ZRzHJfRi8" ]
|
,"o2KiCX5'ZRzHJfRi8" ]
|
||||||
, Pat.PVar "su'BrrbPUK6I33Eq" ]
|
, P.Var "su'BrrbPUK6I33Eq"
|
||||||
|
]
|
||||||
|
|
||||||
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
|
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
|
||||||
prop_parse_print p x =
|
prop_parse_print p x =
|
||||||
either (const False) (== x) . parse_print p $ x
|
either (const False) (== x) . parse_print p $ x
|
||||||
|
|
||||||
parse_print :: (Pretty a) => IParser a -> a -> Either String a
|
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
|
||||||
|
|
|
@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Parse.Helpers (reserveds)
|
import qualified Parse.Helpers (reserveds)
|
||||||
|
|
||||||
import SourceSyntax.Literal
|
import qualified SourceSyntax.Literal as L
|
||||||
import SourceSyntax.Pattern
|
import qualified SourceSyntax.Pattern as P
|
||||||
import SourceSyntax.Type hiding (listOf)
|
import qualified SourceSyntax.Type as T
|
||||||
|
|
||||||
instance Arbitrary Literal where
|
instance Arbitrary L.Literal where
|
||||||
arbitrary = oneof [ IntNum <$> arbitrary
|
arbitrary =
|
||||||
, FloatNum <$> (arbitrary `suchThat` noE)
|
oneof
|
||||||
, Chr <$> arbitrary
|
[ L.IntNum <$> arbitrary
|
||||||
-- This is too permissive
|
, L.FloatNum <$> (arbitrary `suchThat` noE)
|
||||||
, Str <$> arbitrary
|
, L.Chr <$> arbitrary
|
||||||
-- Booleans aren't actually source syntax
|
-- This is too permissive
|
||||||
-- , Boolean <$> arbitrary
|
, L.Str <$> arbitrary
|
||||||
]
|
-- Booleans aren't actually source syntax
|
||||||
shrink l = case l of
|
-- , Boolean <$> arbitrary
|
||||||
IntNum n -> IntNum <$> shrink n
|
]
|
||||||
FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
|
|
||||||
Chr c -> Chr <$> shrink c
|
shrink lit =
|
||||||
Str s -> Str <$> shrink s
|
case lit of
|
||||||
Boolean b -> Boolean <$> shrink b
|
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 :: Double -> Bool
|
||||||
noE = notElem 'e' . show
|
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
|
arbitrary = sized pat
|
||||||
where pat :: Int -> Gen Pattern
|
where
|
||||||
pat n = oneof [ pure PAnything
|
pat :: Int -> Gen P.Pattern
|
||||||
, PVar <$> lowVar
|
pat n =
|
||||||
, PRecord <$> (listOf1 lowVar)
|
oneof
|
||||||
, PLiteral <$> arbitrary
|
[ pure P.Anything
|
||||||
, PAlias <$> lowVar <*> pat (n-1)
|
, P.Var <$> lowVar
|
||||||
, PData <$> capVar <*> sizedPats
|
, P.Record <$> (listOf1 lowVar)
|
||||||
]
|
, P.Literal <$> arbitrary
|
||||||
where sizedPats = do
|
, P.Alias <$> lowVar <*> pat (n-1)
|
||||||
len <- choose (0,n)
|
, P.Data <$> capVar <*> genVector n pat
|
||||||
let m = n `div` (len + 1)
|
]
|
||||||
vectorOf len $ pat m
|
|
||||||
|
|
||||||
shrink pat = case pat of
|
shrink pat =
|
||||||
PAnything -> []
|
case pat of
|
||||||
PVar v -> PVar <$> shrinkWHead v
|
P.Anything -> []
|
||||||
PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
|
P.Var v -> P.Var <$> shrinkWHead v
|
||||||
PLiteral l -> PLiteral <$> shrink l
|
P.Literal l -> P.Literal <$> shrink l
|
||||||
PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
|
P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
|
||||||
PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
|
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 :: Arbitrary a => [a] -> [[a]]
|
||||||
shrinkWHead [] = error "Should be nonempty"
|
shrinkWHead [] = error "Should be nonempty"
|
||||||
shrinkWHead (x:xs) = (x:) <$> shrink xs
|
shrinkWHead (x:xs) = (x:) <$> shrink xs
|
||||||
|
|
||||||
instance Arbitrary Type where
|
instance Arbitrary T.Type where
|
||||||
arbitrary = sized tipe
|
arbitrary = sized tipe
|
||||||
where tipe :: Int -> Gen Type
|
where
|
||||||
tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
|
tipe :: Int -> Gen T.Type
|
||||||
, Var <$> lowVar
|
tipe n =
|
||||||
, Data <$> capVar <*> depthTipes
|
let depthTipe = tipe =<< choose (0,n)
|
||||||
, Record <$> fields <*> pure Nothing
|
field = (,) <$> lowVar <*> depthTipe
|
||||||
, Record <$> fields1 <*> (Just <$> lowVar)
|
fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
|
||||||
]
|
fields1 = (:) <$> field <*> fields
|
||||||
where depthTipe = choose (0,n) >>= tipe
|
in
|
||||||
depthTipes = do
|
oneof
|
||||||
len <- choose (0,n)
|
[ T.Lambda <$> depthTipe <*> depthTipe
|
||||||
let m = n `div` (len + 1)
|
, T.Var <$> lowVar
|
||||||
vectorOf len $ tipe m
|
, T.Data <$> capVar <*> genVector n tipe
|
||||||
|
, T.Record <$> fields <*> pure Nothing
|
||||||
|
, T.Record <$> fields1 <*> (Just <$> lowVar)
|
||||||
|
]
|
||||||
|
|
||||||
field = (,) <$> lowVar <*> depthTipe
|
shrink tipe =
|
||||||
fields = do
|
case tipe of
|
||||||
len <- choose (0,n)
|
T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
|
||||||
let m = n `div` (len + 1)
|
T.Var _ -> []
|
||||||
vectorOf len $ (,) <$> lowVar <*> tipe m
|
T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
|
||||||
fields1 = (:) <$> field <*> fields
|
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
|
shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
||||||
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
|
|
||||||
|
|
||||||
lowVar :: Gen String
|
lowVar :: Gen String
|
||||||
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
|
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
|
||||||
where lower = elements ['a'..'z']
|
where
|
||||||
|
lower = elements ['a'..'z']
|
||||||
|
|
||||||
capVar :: Gen String
|
capVar :: Gen String
|
||||||
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
|
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
|
||||||
where upper = elements ['A'..'Z']
|
where
|
||||||
|
upper = elements ['A'..'Z']
|
||||||
|
|
||||||
varLetter :: Gen Char
|
varLetter :: Gen Char
|
||||||
varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
|
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 :: (Ord a) => Gen a -> [a] -> Gen a
|
||||||
exceptFor g xs = g `suchThat` notAnX
|
exceptFor g xs = g `suchThat` notAnX
|
||||||
where notAnX = flip Set.notMember xset
|
where
|
||||||
xset = Set.fromList xs
|
notAnX = flip Set.notMember xset
|
||||||
|
xset = Set.fromList xs
|
||||||
|
|
Loading…
Reference in a new issue