Style changes and making things compatible with new Pattern constructor names
This commit is contained in:
Evan Czaplicki
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 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,9 +31,9 @@ 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_"
|
||||
longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
|
||||
, P.Record
|
||||
[ "q7yclkcm7k_ikstrczv_"
|
||||
, "wQRv6gKsvvkjw4b5F"
|
||||
,"c9'eFfhk9FTvsMnwF_D"
|
||||
,"yqxhEkHvRFwZ"
|
||||
|
|
@ -44,11 +44,12 @@ propertyTests =
|
|||
,"sHHsX"
|
||||
,"mRKs9d"
|
||||
,"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 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
instance Arbitrary L.Literal where
|
||||
arbitrary =
|
||||
oneof
|
||||
[ L.IntNum <$> arbitrary
|
||||
, L.FloatNum <$> (arbitrary `suchThat` noE)
|
||||
, L.Chr <$> arbitrary
|
||||
-- This is too permissive
|
||||
, Str <$> arbitrary
|
||||
, L.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
|
||||
|
||||
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
|
||||
|
||||
|
||||
instance Arbitrary 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
|
||||
genVector :: Int -> (Int -> Gen a) -> Gen [a]
|
||||
genVector n generator = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ pat m
|
||||
vectorOf len $ generator m
|
||||
|
||||
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)
|
||||
instance Arbitrary P.Pattern where
|
||||
arbitrary = sized pat
|
||||
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
|
||||
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 = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ (,) <$> lowVar <*> tipe m
|
||||
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)
|
||||
]
|
||||
|
||||
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
|
||||
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 $ Record fields t
|
||||
where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
||||
do fields <- filter (not . null) $ shrinkList shrinkField fs
|
||||
return $ T.Record fields 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
|
||||
where
|
||||
notAnX = flip Set.notMember xset
|
||||
xset = Set.fromList xs
|
||||
|
|
|
|||
Loading…
Reference in a new issue