Merge pull request #421 from maxsnew/test

Test Re-org and Start Property Testing

.gitignore

@@ -10,3 +10,4 @@ cabal-dev
 data
 */ElmFiles/*
 .DS_Store
+*~

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

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 =

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

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
+main = defaultMain [ compilerTests
+                   , propertyTests
+                   ]

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"

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

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