From 840eca65735f11dc90288dcb9ff67fc70479ad99 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 13:44:25 -0600 Subject: [PATCH 1/7] Migrate tests to test-framework and make them more specific. Use test-framework as it's more widely used/has better support for HUnit/QuickCheck. Make test cases test the `compile` function explicitly instead of the elm executable as that's all they're actually intended to test. --- Elm.cabal | 8 +++++++- tests/Main.hs | 48 ++++++++++++++++++++++++++++++++---------------- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/Elm.cabal b/Elm.cabal index f33ee63..cd796be 100644 --- a/Elm.cabal +++ b/Elm.cabal @@ -230,4 +230,10 @@ Test-Suite test-elm Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests Main-is: Main.hs - build-depends: base, directory, HTF + build-depends: base, + directory, + Elm, + test-framework, + test-framework-hunit, + HUnit, + filemanip diff --git a/tests/Main.hs b/tests/Main.hs index 4119223..33483cc 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,22 +1,38 @@ module Main where -import System.Directory -import System.Exit (exitWith) -import System.Environment (getArgs) -import Test.Framework.TestManager -import Test.Framework.BlackBoxTest +import Data.Functor ((<$>)) +import Data.Traversable (traverse) +import System.FilePath.Find (find, (==?), extension) +import Test.Framework +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), Assertion) + +import Elm.Internal.Utils as Elm main :: IO () -main = do - args <- getArgs - tests <- blackBoxTests "tests" "dist/build/elm/elm" ".elm" bbtArgs - code <- runTestWithArgs args tests - removeDirectoryRecursive "cache" - removeDirectoryRecursive "build" - exitWith code +main = defaultMain [compilerTests] -bbtArgs = defaultBBTArgs { bbtArgs_stdoutDiff = ignoreDiff - , bbtArgs_stderrDiff = ignoreDiff } +compilerTests :: Test +compilerTests = buildTest $ do + goods <- getElms "tests/good" >>= mkTests True + bads <- getElms "tests/bad" >>= mkTests False -ignoreDiff :: Diff -ignoreDiff _ _ = return Nothing \ No newline at end of file + return $ testGroup "Compile Tests" + [ + testGroup "Good Tests" goods + , testGroup "Bad Tests" bads + ] + + where getElms :: FilePath -> IO [FilePath] + getElms = find (return True) (extension ==? ".elm") + + mkTests :: Bool -> [FilePath] -> IO [Test] + mkTests b = traverse setupTest + where setupTest f = testCase f . mkCompileTest b <$> readFile f + +mkCompileTest :: Bool -- ^ Expect success? + -> String -- ^ File Contents + -> Assertion +mkCompileTest succ modul = noCompileErr @=? succ + where noCompileErr = either (const False) (const True) . Elm.compile $ modul + expectation = "Compile " ++ if succ then "Success" else "Error" From 1408d928d55e2d9bd8c11da1cce8570f7bcd6fa2 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 15:04:25 -0600 Subject: [PATCH 2/7] Re-org tests --- tests/Main.hs | 34 ++---------------- tests/Tests/Compiler.hs | 36 +++++++++++++++++++ tests/{ => data}/bad/BBTArgs | 0 tests/{ => data}/bad/InfiniteType.elm | 0 tests/{ => data}/bad/NonElementMain.elm | 0 tests/{ => data}/good/AliasSubstitution.elm | 0 tests/{ => data}/good/NoExpressions.elm | 0 tests/{ => data}/good/Otherwise.elm | 0 tests/{ => data}/good/QuotesAndComments.elm | 0 tests/{ => data}/good/Soundness/Apply.elm | 0 .../good/Soundness/ApplyAnnotated.elm | 0 tests/{ => data}/good/Soundness/Id.elm | 0 .../{ => data}/good/Soundness/IdAnnotated.elm | 0 tests/{ => data}/good/Soundness/TrickyId.elm | 0 .../good/Soundness/TrickyIdAnnotated.elm | 0 tests/{ => data}/good/Unify/LockedVars.elm | 0 .../good/Unify/NonHomogeneousRecords.elm | 0 17 files changed, 38 insertions(+), 32 deletions(-) create mode 100644 tests/Tests/Compiler.hs rename tests/{ => data}/bad/BBTArgs (100%) rename tests/{ => data}/bad/InfiniteType.elm (100%) rename tests/{ => data}/bad/NonElementMain.elm (100%) rename tests/{ => data}/good/AliasSubstitution.elm (100%) rename tests/{ => data}/good/NoExpressions.elm (100%) rename tests/{ => data}/good/Otherwise.elm (100%) rename tests/{ => data}/good/QuotesAndComments.elm (100%) rename tests/{ => data}/good/Soundness/Apply.elm (100%) rename tests/{ => data}/good/Soundness/ApplyAnnotated.elm (100%) rename tests/{ => data}/good/Soundness/Id.elm (100%) rename tests/{ => data}/good/Soundness/IdAnnotated.elm (100%) rename tests/{ => data}/good/Soundness/TrickyId.elm (100%) rename tests/{ => data}/good/Soundness/TrickyIdAnnotated.elm (100%) rename tests/{ => data}/good/Unify/LockedVars.elm (100%) rename tests/{ => data}/good/Unify/NonHomogeneousRecords.elm (100%) diff --git a/tests/Main.hs b/tests/Main.hs index 33483cc..13547b3 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,38 +1,8 @@ module Main where -import Data.Functor ((<$>)) -import Data.Traversable (traverse) -import System.FilePath.Find (find, (==?), extension) import Test.Framework -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), Assertion) -import Elm.Internal.Utils as Elm +import Tests.Compiler main :: IO () -main = defaultMain [compilerTests] - -compilerTests :: Test -compilerTests = buildTest $ do - goods <- getElms "tests/good" >>= mkTests True - bads <- getElms "tests/bad" >>= mkTests False - - return $ testGroup "Compile Tests" - [ - testGroup "Good Tests" goods - , testGroup "Bad Tests" bads - ] - - where getElms :: FilePath -> IO [FilePath] - getElms = find (return True) (extension ==? ".elm") - - mkTests :: Bool -> [FilePath] -> IO [Test] - mkTests b = traverse setupTest - where setupTest f = testCase f . mkCompileTest b <$> readFile f - -mkCompileTest :: Bool -- ^ Expect success? - -> String -- ^ File Contents - -> Assertion -mkCompileTest succ modul = noCompileErr @=? succ - where noCompileErr = either (const False) (const True) . Elm.compile $ modul - expectation = "Compile " ++ if succ then "Success" else "Error" +main = defaultMain [ compilerTests ] diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs new file mode 100644 index 0000000..81162c8 --- /dev/null +++ b/tests/Tests/Compiler.hs @@ -0,0 +1,36 @@ +module Tests.Compiler (compilerTests) + where + +import Data.Functor ((<$>)) +import Data.Traversable (traverse) +import System.FilePath.Find (find, (==?), extension) +import Test.Framework +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), Assertion) + +import Elm.Internal.Utils as Elm + +compilerTests :: Test +compilerTests = buildTest $ do + goods <- getElms "tests/data/good" >>= mkTests True + bads <- getElms "tests/data/bad" >>= mkTests False + + return $ testGroup "Compile Tests" + [ + testGroup "Good Tests" goods + , testGroup "Bad Tests" bads + ] + + where getElms :: FilePath -> IO [FilePath] + getElms = find (return True) (extension ==? ".elm") + + mkTests :: Bool -> [FilePath] -> IO [Test] + mkTests b = traverse setupTest + where setupTest f = testCase f . mkCompileTest b <$> readFile f + +mkCompileTest :: Bool -- ^ Expect success? + -> String -- ^ File Contents + -> Assertion +mkCompileTest succ modul = noCompileErr @=? succ + where noCompileErr = either (const False) (const True) . Elm.compile $ modul + expectation = "Compile " ++ if succ then "Success" else "Error" diff --git a/tests/bad/BBTArgs b/tests/data/bad/BBTArgs similarity index 100% rename from tests/bad/BBTArgs rename to tests/data/bad/BBTArgs diff --git a/tests/bad/InfiniteType.elm b/tests/data/bad/InfiniteType.elm similarity index 100% rename from tests/bad/InfiniteType.elm rename to tests/data/bad/InfiniteType.elm diff --git a/tests/bad/NonElementMain.elm b/tests/data/bad/NonElementMain.elm similarity index 100% rename from tests/bad/NonElementMain.elm rename to tests/data/bad/NonElementMain.elm diff --git a/tests/good/AliasSubstitution.elm b/tests/data/good/AliasSubstitution.elm similarity index 100% rename from tests/good/AliasSubstitution.elm rename to tests/data/good/AliasSubstitution.elm diff --git a/tests/good/NoExpressions.elm b/tests/data/good/NoExpressions.elm similarity index 100% rename from tests/good/NoExpressions.elm rename to tests/data/good/NoExpressions.elm diff --git a/tests/good/Otherwise.elm b/tests/data/good/Otherwise.elm similarity index 100% rename from tests/good/Otherwise.elm rename to tests/data/good/Otherwise.elm diff --git a/tests/good/QuotesAndComments.elm b/tests/data/good/QuotesAndComments.elm similarity index 100% rename from tests/good/QuotesAndComments.elm rename to tests/data/good/QuotesAndComments.elm diff --git a/tests/good/Soundness/Apply.elm b/tests/data/good/Soundness/Apply.elm similarity index 100% rename from tests/good/Soundness/Apply.elm rename to tests/data/good/Soundness/Apply.elm diff --git a/tests/good/Soundness/ApplyAnnotated.elm b/tests/data/good/Soundness/ApplyAnnotated.elm similarity index 100% rename from tests/good/Soundness/ApplyAnnotated.elm rename to tests/data/good/Soundness/ApplyAnnotated.elm diff --git a/tests/good/Soundness/Id.elm b/tests/data/good/Soundness/Id.elm similarity index 100% rename from tests/good/Soundness/Id.elm rename to tests/data/good/Soundness/Id.elm diff --git a/tests/good/Soundness/IdAnnotated.elm b/tests/data/good/Soundness/IdAnnotated.elm similarity index 100% rename from tests/good/Soundness/IdAnnotated.elm rename to tests/data/good/Soundness/IdAnnotated.elm diff --git a/tests/good/Soundness/TrickyId.elm b/tests/data/good/Soundness/TrickyId.elm similarity index 100% rename from tests/good/Soundness/TrickyId.elm rename to tests/data/good/Soundness/TrickyId.elm diff --git a/tests/good/Soundness/TrickyIdAnnotated.elm b/tests/data/good/Soundness/TrickyIdAnnotated.elm similarity index 100% rename from tests/good/Soundness/TrickyIdAnnotated.elm rename to tests/data/good/Soundness/TrickyIdAnnotated.elm diff --git a/tests/good/Unify/LockedVars.elm b/tests/data/good/Unify/LockedVars.elm similarity index 100% rename from tests/good/Unify/LockedVars.elm rename to tests/data/good/Unify/LockedVars.elm diff --git a/tests/good/Unify/NonHomogeneousRecords.elm b/tests/data/good/Unify/NonHomogeneousRecords.elm similarity index 100% rename from tests/good/Unify/NonHomogeneousRecords.elm rename to tests/data/good/Unify/NonHomogeneousRecords.elm From 2da9009512c41f58b55b50a6f996bb802c96bca7 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 15:18:40 -0600 Subject: [PATCH 3/7] Setup QuickCheck and add Literal Parse/Print test Currently fails the prop tests: https://github.com/evancz/Elm/issues/420 Also ignore emacs backup files. --- .gitignore | 1 + Elm.cabal | 33 +++++++++++++++++++++++++++++-- compiler/SourceSyntax/Literal.hs | 4 ++-- tests/Main.hs | 5 ++++- tests/Tests/Property.hs | 22 +++++++++++++++++++++ tests/Tests/Property/Arbitrary.hs | 23 +++++++++++++++++++++ 6 files changed, 83 insertions(+), 5 deletions(-) create mode 100644 tests/Tests/Property.hs create mode 100644 tests/Tests/Property/Arbitrary.hs diff --git a/.gitignore b/.gitignore index a502b8e..d096822 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ cabal-dev data */ElmFiles/* .DS_Store +*~ diff --git a/Elm.cabal b/Elm.cabal index cd796be..86ad2a7 100644 --- a/Elm.cabal +++ b/Elm.cabal @@ -228,12 +228,41 @@ Executable elm-doc Test-Suite test-elm Type: exitcode-stdio-1.0 - Hs-Source-Dirs: tests + Hs-Source-Dirs: tests, compiler Main-is: Main.hs + other-modules: Tests.Compiler + Tests.Property + Tests.Property.Arbitrary + SourceSyntax.Helpers + SourceSyntax.Literal + SourceSyntax.PrettyPrint build-depends: base, directory, Elm, test-framework, test-framework-hunit, + test-framework-quickcheck2, HUnit, - filemanip + pretty, + QuickCheck >= 2 && < 3, + filemanip, + aeson, + base >=4.2 && <5, + binary >= 0.6.4.0, + blaze-html == 0.5.* || == 0.6.*, + blaze-markup == 0.5.1.*, + bytestring, + cmdargs, + containers >= 0.3, + directory, + filepath, + indents, + language-ecmascript >=0.15 && < 1.0, + mtl >= 2, + pandoc >= 1.10, + parsec >= 3.1.1, + pretty, + text, + transformers >= 0.2, + union-find, + unordered-containers diff --git a/compiler/SourceSyntax/Literal.hs b/compiler/SourceSyntax/Literal.hs index a7bdb9d..1fe0577 100644 --- a/compiler/SourceSyntax/Literal.hs +++ b/compiler/SourceSyntax/Literal.hs @@ -8,7 +8,7 @@ data Literal = IntNum Int | Chr Char | Str String | Boolean Bool - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) instance Pretty Literal where pretty literal = @@ -17,4 +17,4 @@ instance Pretty Literal where FloatNum n -> PP.double n Chr c -> PP.quotes (PP.char c) Str s -> PP.text (show s) - Boolean bool -> PP.text (show bool) \ No newline at end of file + Boolean bool -> PP.text (show bool) diff --git a/tests/Main.hs b/tests/Main.hs index 13547b3..72c3021 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -3,6 +3,9 @@ module Main where import Test.Framework import Tests.Compiler +import Tests.Property main :: IO () -main = defaultMain [ compilerTests ] +main = defaultMain [ compilerTests + , propertyTests + ] diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs new file mode 100644 index 0000000..ee036c5 --- /dev/null +++ b/tests/Tests/Property.hs @@ -0,0 +1,22 @@ +module Tests.Property where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import SourceSyntax.Literal (Literal) +import SourceSyntax.PrettyPrint (pretty) +import Parse.Helpers (iParse) +import Parse.Literal (literal) +import Tests.Property.Arbitrary + +propertyTests :: Test +propertyTests = + testGroup "Parse/Print Agreement Tests" + [ + testProperty "Literal test" prop_literal_parse_print + ] + +prop_literal_parse_print :: Literal -> Bool +prop_literal_parse_print l = + either (const False) (== l) . iParse literal . show . pretty $ l diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs new file mode 100644 index 0000000..c5fa1e4 --- /dev/null +++ b/tests/Tests/Property/Arbitrary.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.Property.Arbitrary where + +import Control.Applicative ((<$>)) +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +import SourceSyntax.Literal + +instance Arbitrary Literal where + arbitrary = oneof [ IntNum <$> arbitrary + , FloatNum <$> arbitrary + , Chr <$> arbitrary + , Str <$> arbitrary + -- Booleans aren't actually source syntax + -- , Boolean <$> arbitrary + ] + shrink l = case l of + IntNum n -> IntNum <$> shrink n + FloatNum f -> FloatNum <$> shrink f + Chr c -> Chr <$> shrink c + Str s -> Str <$> shrink s + Boolean b -> Boolean <$> shrink b From 24751a3d85a140fbcbe350f771e98e3747029493 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 20:18:45 -0600 Subject: [PATCH 4/7] Add parse/print tests for Patterns. --- tests/Tests/Property.hs | 17 +++++++---- tests/Tests/Property/Arbitrary.hs | 51 ++++++++++++++++++++++++++++++- 2 files changed, 61 insertions(+), 7 deletions(-) diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs index ee036c5..71c73c2 100644 --- a/tests/Tests/Property.hs +++ b/tests/Tests/Property.hs @@ -5,18 +5,23 @@ import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import SourceSyntax.Literal (Literal) -import SourceSyntax.PrettyPrint (pretty) -import Parse.Helpers (iParse) +import SourceSyntax.PrettyPrint (Pretty, pretty) +import Parse.Helpers (IParser, iParse) import Parse.Literal (literal) +import Parse.Pattern (expr) import Tests.Property.Arbitrary propertyTests :: Test propertyTests = testGroup "Parse/Print Agreement Tests" [ - testProperty "Literal test" prop_literal_parse_print + testProperty "Literal test" $ prop_parse_print literal + , testProperty "Pattern test" $ prop_parse_print expr ] -prop_literal_parse_print :: Literal -> Bool -prop_literal_parse_print l = - either (const False) (== l) . iParse literal . show . pretty $ l +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 . show . pretty diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs index c5fa1e4..011c9e6 100644 --- a/tests/Tests/Property/Arbitrary.hs +++ b/tests/Tests/Property/Arbitrary.hs @@ -1,16 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Tests.Property.Arbitrary where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>), pure) import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen +import qualified Data.Set as Set +import qualified Parse.Helpers (reserveds) + import SourceSyntax.Literal +import SourceSyntax.Pattern instance Arbitrary Literal where arbitrary = oneof [ IntNum <$> arbitrary , FloatNum <$> arbitrary , Chr <$> arbitrary + -- This is too permissive , Str <$> arbitrary -- Booleans aren't actually source syntax -- , Boolean <$> arbitrary @@ -21,3 +26,47 @@ instance Arbitrary Literal where Chr c -> Chr <$> shrink c Str s -> Str <$> shrink s Boolean b -> Boolean <$> shrink b + +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 + len <- choose (0,n) + let m = n `div` len in + vectorOf len $ pat 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) + where shrinkWHead (x:xs) = (x:) <$> shrink xs + +lowVar :: Gen String +lowVar = notReserved $ (:) <$> lower <*> listOf varLetter + where lower = elements ['a'..'z'] + +capVar :: Gen String +capVar = notReserved $ (:) <$> upper <*> listOf varLetter + where upper = elements ['A'..'Z'] + +varLetter :: Gen Char +varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_'] + +notReserved :: Gen String -> Gen String +notReserved = flip exceptFor Parse.Helpers.reserveds + +exceptFor :: (Ord a) => Gen a -> [a] -> Gen a +exceptFor g xs = suchThat g notAnX + where notAnX = flip Set.notMember xset + xset = Set.fromList xs + From d0030625868662bec22077f36a49cbff9098ec7e Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 20:19:21 -0600 Subject: [PATCH 5/7] Pattern pretty printer prints syntactically correct code. Include auto-generated test case that was previously broken. --- compiler/SourceSyntax/Pattern.hs | 4 ++-- tests/Tests/Property.hs | 34 ++++++++++++++++++++++++++------ 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/compiler/SourceSyntax/Pattern.hs b/compiler/SourceSyntax/Pattern.hs index 0328091..91d0cfc 100644 --- a/compiler/SourceSyntax/Pattern.hs +++ b/compiler/SourceSyntax/Pattern.hs @@ -35,7 +35,7 @@ instance Pretty Pattern where PData name ps -> if isTuple name then PP.parens . commaCat $ map pretty ps - else sep (PP.text name : map prettyParens ps) + else hsep (PP.text name : map prettyParens ps) prettyParens pattern = parensIf needsThem (pretty pattern) where @@ -43,4 +43,4 @@ prettyParens pattern = parensIf needsThem (pretty pattern) case pattern of PData name (_:_) | not (isTuple name) -> True PAlias _ _ -> True - _ -> False \ No newline at end of file + _ -> False diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs index 71c73c2..ef36da4 100644 --- a/tests/Tests/Property.hs +++ b/tests/Tests/Property.hs @@ -1,24 +1,46 @@ module Tests.Property where import Test.Framework +import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 +import Test.HUnit (assert) import Test.QuickCheck -import SourceSyntax.Literal (Literal) -import SourceSyntax.PrettyPrint (Pretty, pretty) -import Parse.Helpers (IParser, iParse) -import Parse.Literal (literal) -import Parse.Pattern (expr) +import SourceSyntax.Literal as Lit +import SourceSyntax.Pattern as Pat +import SourceSyntax.PrettyPrint (Pretty, pretty) +import Parse.Helpers (IParser, iParse) +import Parse.Literal (literal) +import Parse.Pattern (expr) import Tests.Property.Arbitrary propertyTests :: Test propertyTests = testGroup "Parse/Print Agreement Tests" [ - testProperty "Literal test" $ prop_parse_print literal + testCase "Long Pattern test" $ assert (prop_parse_print expr longPat) + , testProperty "Literal test" $ prop_parse_print literal , testProperty "Pattern test" $ prop_parse_print expr ] + 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" ] + 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 From 37f5d9e1eaac5953829397a458f671125f1a3f80 Mon Sep 17 00:00:00 2001 From: Max New Date: Sun, 29 Dec 2013 22:11:19 -0600 Subject: [PATCH 6/7] Make parse/print test more stringent, tweak Float gen. --- tests/Tests/Property.hs | 4 +++- tests/Tests/Property/Arbitrary.hs | 11 +++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs index ef36da4..06fa520 100644 --- a/tests/Tests/Property.hs +++ b/tests/Tests/Property.hs @@ -1,10 +1,12 @@ module Tests.Property where +import Control.Applicative ((<*)) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit (assert) import Test.QuickCheck +import Text.Parsec.Combinator (eof) import SourceSyntax.Literal as Lit import SourceSyntax.Pattern as Pat @@ -46,4 +48,4 @@ 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 . show . pretty +parse_print p = either (Left . show) (Right) . iParse (p <* eof) . show . pretty diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs index 011c9e6..3c64376 100644 --- a/tests/Tests/Property/Arbitrary.hs +++ b/tests/Tests/Property/Arbitrary.hs @@ -13,7 +13,7 @@ import SourceSyntax.Pattern instance Arbitrary Literal where arbitrary = oneof [ IntNum <$> arbitrary - , FloatNum <$> arbitrary + , FloatNum <$> (arbitrary `suchThat` noE) , Chr <$> arbitrary -- This is too permissive , Str <$> arbitrary @@ -22,11 +22,15 @@ instance Arbitrary Literal where ] shrink l = case l of IntNum n -> IntNum <$> shrink n - FloatNum f -> FloatNum <$> shrink f + FloatNum f -> FloatNum <$> (filter noE . shrink $ f) Chr c -> Chr <$> shrink c Str s -> Str <$> shrink s Boolean b -> Boolean <$> shrink b +noE :: Double -> Bool +noE = notElem 'e' . show + + instance Arbitrary Pattern where arbitrary = sized pat where pat :: Int -> Gen Pattern @@ -66,7 +70,6 @@ notReserved :: Gen String -> Gen String notReserved = flip exceptFor Parse.Helpers.reserveds exceptFor :: (Ord a) => Gen a -> [a] -> Gen a -exceptFor g xs = suchThat g notAnX +exceptFor g xs = g `suchThat` notAnX where notAnX = flip Set.notMember xset xset = Set.fromList xs - From dcac0e0d5c41d12b61a1af5cd8de47c79573bcac Mon Sep 17 00:00:00 2001 From: Max New Date: Mon, 30 Dec 2013 02:19:02 -0600 Subject: [PATCH 7/7] Style tweaks and use cross-platform file name construction. --- tests/Tests/Compiler.hs | 10 ++++++---- tests/Tests/Property/Arbitrary.hs | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs index 81162c8..1bd2e85 100644 --- a/tests/Tests/Compiler.hs +++ b/tests/Tests/Compiler.hs @@ -3,6 +3,7 @@ module Tests.Compiler (compilerTests) import Data.Functor ((<$>)) import Data.Traversable (traverse) +import System.FilePath (()) import System.FilePath.Find (find, (==?), extension) import Test.Framework import Test.Framework.Providers.HUnit (testCase) @@ -12,9 +13,8 @@ import Elm.Internal.Utils as Elm compilerTests :: Test compilerTests = buildTest $ do - goods <- getElms "tests/data/good" >>= mkTests True - bads <- getElms "tests/data/bad" >>= mkTests False - + goods <- mkTests True =<< getElms "good" + bads <- mkTests False =<< getElms "bad" return $ testGroup "Compile Tests" [ testGroup "Good Tests" goods @@ -22,12 +22,14 @@ compilerTests = buildTest $ do ] where getElms :: FilePath -> IO [FilePath] - getElms = find (return True) (extension ==? ".elm") + getElms fname = find (return True) (extension ==? ".elm") (testsDir fname) mkTests :: Bool -> [FilePath] -> IO [Test] mkTests b = traverse setupTest where setupTest f = testCase f . mkCompileTest b <$> readFile f + testsDir = "tests" "data" + mkCompileTest :: Bool -- ^ Expect success? -> String -- ^ File Contents -> Assertion diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs index 3c64376..f9b7787 100644 --- a/tests/Tests/Property/Arbitrary.hs +++ b/tests/Tests/Property/Arbitrary.hs @@ -49,7 +49,7 @@ instance Arbitrary Pattern where shrink pat = case pat of PAnything -> [] PVar v -> PVar <$> shrinkWHead v - PRecord fs -> PRecord <$> (filter (all $ not.null) . filter (not.null) $ shrink fs) + 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)