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 f33ee63..86ad2a7 100644 --- a/Elm.cabal +++ b/Elm.cabal @@ -228,6 +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 - build-depends: base, directory, HTF + 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, + 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/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/Main.hs b/tests/Main.hs index 4119223..72c3021 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,22 +1,11 @@ module Main where -import System.Directory -import System.Exit (exitWith) -import System.Environment (getArgs) -import Test.Framework.TestManager -import Test.Framework.BlackBoxTest +import Test.Framework + +import Tests.Compiler +import Tests.Property 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 - -bbtArgs = defaultBBTArgs { bbtArgs_stdoutDiff = ignoreDiff - , bbtArgs_stderrDiff = ignoreDiff } - -ignoreDiff :: Diff -ignoreDiff _ _ = return Nothing \ No newline at end of file +main = defaultMain [ compilerTests + , propertyTests + ] diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs new file mode 100644 index 0000000..1bd2e85 --- /dev/null +++ b/tests/Tests/Compiler.hs @@ -0,0 +1,38 @@ +module Tests.Compiler (compilerTests) + where + +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) +import Test.HUnit ((@=?), Assertion) + +import Elm.Internal.Utils as Elm + +compilerTests :: Test +compilerTests = buildTest $ do + goods <- mkTests True =<< getElms "good" + bads <- mkTests False =<< getElms "bad" + return $ testGroup "Compile Tests" + [ + testGroup "Good Tests" goods + , testGroup "Bad Tests" bads + ] + + where getElms :: FilePath -> IO [FilePath] + 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 +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/Tests/Property.hs b/tests/Tests/Property.hs new file mode 100644 index 0000000..06fa520 --- /dev/null +++ b/tests/Tests/Property.hs @@ -0,0 +1,51 @@ +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 +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" + [ + 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 + +parse_print :: (Pretty a) => IParser a -> a -> Either String a +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 new file mode 100644 index 0000000..f9b7787 --- /dev/null +++ b/tests/Tests/Property/Arbitrary.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.Property.Arbitrary where + +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 `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 + +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 + 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 = g `suchThat` notAnX + where notAnX = flip Set.notMember xset + xset = Set.fromList xs 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