@@ -26,8 +26,8 @@ import Prelude.Compat
2626import qualified Language.PureScript as P
2727
2828import Data.Char (isSpace)
29−import Data.Maybe (mapMaybe, fromMaybe)
30−import Data.List (isSuffixOf, sort, stripPrefix)
29+import Data.Maybe (mapMaybe)
30+import Data.List (isSuffixOf, sort, stripPrefix, intercalate)
3131import Data.Time.Clock (UTCTime())
3232
3333import qualified Data.Map as M
@@ -44,42 +44,57 @@ import System.Process hiding (cwd)
4444import System.FilePath
4545import System.Directory
4646import System.IO.UTF8
47+import System.IO.Silently
4748import qualified System.FilePath.Glob as Glob
4849
4950import TestUtils
51+import Test.Hspec
5052
5153main :: IO ()
52−main = do
53− cwd <- getCurrentDirectory
54+main = hspec spec
5455
55− let supportDir = cwd </> "tests" </> "support" </> "bower_components"
56− let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
56+spec :: Spec
57+spec = do
58+ (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) <- runIO $ do
59+ cwd <- getCurrentDirectory
5760
58− supportPurs <- supportFiles "purs"
59− supportJS <- supportFiles "js"
61+ let supportDir = cwd </> "tests" </> "support" </> "bower_components"
62+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
6063
61− foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
62− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
64+ supportPurs <- supportFiles "purs"
65+ supportJS <- supportFiles "js"
6366
64− let passing = cwd </> "examples" </> "passing"
65− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
66− let failing = cwd </> "examples" </> "failing"
67− failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
67+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
68+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
6869
69− failures <- execWriterT $ do
70+ let passing = cwd </> "examples" </> "passing"
71+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
72+
73+ let failing = cwd </> "examples" </> "failing"
74+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
75+
76+ return (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases)
77+
78+ context ("Passing examples") $ do
7079 forM_ passingTestCases $ \inputFile ->
71− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
72− forM_ failingTestCases $ \inputFile ->
73− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
74−
75− if null failures
76− then pure ()
77− else do
78− putStrLn "Failures:"
79− forM_ failures $ \(fp, err) ->
80− let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
81− in putStrLn $ fp' ++ ": " ++ err
82− exitFailure
80+ it ("'" <> inputFile <> "' should compile and run without error") $ do
81+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
82+
83+ context ("Failing examples") $ do
84+ forM_ failingTestCases $ \inputFile -> do
85+ expectedFailures <- runIO $ getShouldFailWith (failing </> inputFile)
86+ it ("'" <> inputFile <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
87+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns expectedFailures
88+
89+ where
90+
91+ getShouldFailWith :: FilePath -> IO [String]
92+ getShouldFailWith = fmap extractFailWiths . readUTF8File
93+ where
94+ extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim
95+
96+trim :: String -> String
97+trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
8398
8499modulesDir :: FilePath
85100modulesDir = ".test_modules" </> "node_modules"
@@ -113,26 +128,27 @@ type TestM = WriterT [(FilePath, String)] IO
113128runTest :: P.Make a -> IO (Either P.MultipleErrors a)
114129runTest = fmap fst . P.runMake P.defaultOptions
115130
116−compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
117−compile inputFiles foreigns = runTest $ do
131+compile
132+ :: [FilePath]
133+ -> M.Map P.ModuleName FilePath
134+ -> IO (Either P.MultipleErrors P.Environment)
135+compile inputFiles foreigns = silence $ runTest $ do
118136 fs <- liftIO $ readInput inputFiles
119137 ms <- P.parseModulesFromFiles id fs
120138 P.make (makeActions foreigns) (map snd ms)
121139
122−assert :: [FilePath] ->
123− M.Map P.ModuleName FilePath ->
124− (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
125− TestM ()
140+assert
141+ :: [FilePath]
142+ -> M.Map P.ModuleName FilePath
143+ -> (Either P.MultipleErrors P.Environment -> IO (Maybe String))
144+ -> Expectation
126145assert inputFiles foreigns f = do
127− e <- liftIO $ compile inputFiles foreigns
128− maybeErr <- liftIO $ f e
129− case maybeErr of
130− Just err -> tell [(last inputFiles, err)]
131− Nothing -> return ()
146+ e <- compile inputFiles foreigns
147+ maybeErr <- f e
148+ maybe (return ()) expectationFailure maybeErr
132149
133−assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
150+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation
134151assertCompiles inputFiles foreigns = do
135− liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
136152 assert inputFiles foreigns $ \e ->
137153 case e of
138154 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
@@ -142,19 +158,22 @@ assertCompiles inputFiles foreigns = do
142158 writeFile entryPoint "require('Main').main()"
143159 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
144160 case result of
145− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
161+ Just (ExitSuccess, out, err)
162+ | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
163+ | trim (last (lines out)) == "Done" -> return Nothing
164+ | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
146165 Just (ExitFailure _, _, err) -> return $ Just err
147166 Nothing -> return $ Just "Couldn't find node.js executable"
148167
149−assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
150−assertDoesNotCompile inputFiles foreigns = do
151− let testFile = last inputFiles
152− liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
153− shouldFailWith <- getShouldFailWith testFile
168+assertDoesNotCompile
169+ :: [FilePath]
170+ -> M.Map P.ModuleName FilePath
171+ -> [String]
172+ -> Expectation
173+assertDoesNotCompile inputFiles foreigns shouldFailWith = do
154174 assert inputFiles foreigns $ \e ->
155175 case e of
156176 Left errs -> do
157− putStrLn (P.prettyPrintMultipleErrors False errs)
158177 return $ if null shouldFailWith
159178 then Just $ "shouldFailWith declaration is missing (errors were: "
160179 ++ show (map P.errorCode (P.runMultipleErrors errs))
@@ -164,19 +183,8 @@ assertDoesNotCompile inputFiles foreigns = do
164183 return $ Just "Should not have compiled"
165184
166185 where
167− getShouldFailWith =
168− readUTF8File
169− >>> liftIO
170− >>> fmap ( lines
171− >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
172− >>> map trim
173− )
174−
175186 checkShouldFailWith expected errs =
176187 let actual = map P.errorCode $ P.runMultipleErrors errs
177188 in if sort expected == sort actual
178189 then Nothing
179190 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
180−
181− trim =
182− dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse