Style changes and making things compatible with new Pattern constructor names

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 '+')
+    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 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

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 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 = 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
+    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 [] = 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
+    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 = 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
-        xset = Set.fromList xs
+    notAnX = flip Set.notMember xset
+    xset = Set.fromList xs