@@ -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,55 @@ 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+ trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
8396
8497modulesDir :: FilePath
8598modulesDir = ".test_modules" </> "node_modules"
@@ -113,26 +126,27 @@ type TestM = WriterT [(FilePath, String)] IO
113126runTest :: P.Make a -> IO (Either P.MultipleErrors a)
114127runTest = fmap fst . P.runMake P.defaultOptions
115128
116−compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
117−compile inputFiles foreigns = runTest $ do
129+compile
130+ :: [FilePath]
131+ -> M.Map P.ModuleName FilePath
132+ -> IO (Either P.MultipleErrors P.Environment)
133+compile inputFiles foreigns = silence $ runTest $ do
118134 fs <- liftIO $ readInput inputFiles
119135 ms <- P.parseModulesFromFiles id fs
120136 P.make (makeActions foreigns) (map snd ms)
121137
122−assert :: [FilePath] ->
123− M.Map P.ModuleName FilePath ->
124− (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
125− TestM ()
138+assert
139+ :: [FilePath]
140+ -> M.Map P.ModuleName FilePath
141+ -> (Either P.MultipleErrors P.Environment -> IO (Maybe String))
142+ -> Expectation
126143assert 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 ()
144+ e <- compile inputFiles foreigns
145+ maybeErr <- f e
146+ maybe (return ()) expectationFailure maybeErr
132147
133−assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
148+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation
134149assertCompiles inputFiles foreigns = do
135− liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
136150 assert inputFiles foreigns $ \e ->
137151 case e of
138152 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
@@ -142,19 +156,19 @@ assertCompiles inputFiles foreigns = do
142156 writeFile entryPoint "require('Main').main()"
143157 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
144158 case result of
145− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
159+ Just (ExitSuccess, _, _) -> return Nothing
146160 Just (ExitFailure _, _, err) -> return $ Just err
147161 Nothing -> return $ Just "Couldn't find node.js executable"
148162
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
163+assertDoesNotCompile
164+ :: [FilePath]
165+ -> M.Map P.ModuleName FilePath
166+ -> [String]
167+ -> Expectation
168+assertDoesNotCompile inputFiles foreigns shouldFailWith = do
154169 assert inputFiles foreigns $ \e ->
155170 case e of
156171 Left errs -> do
157− putStrLn (P.prettyPrintMultipleErrors False errs)
158172 return $ if null shouldFailWith
159173 then Just $ "shouldFailWith declaration is missing (errors were: "
160174 ++ show (map P.errorCode (P.runMultipleErrors errs))
@@ -164,19 +178,8 @@ assertDoesNotCompile inputFiles foreigns = do
164178 return $ Just "Should not have compiled"
165179
166180 where
167− getShouldFailWith =
168− readUTF8File
169− >>> liftIO
170− >>> fmap ( lines
171− >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
172− >>> map trim
173− )
174−
175181 checkShouldFailWith expected errs =
176182 let actual = map P.errorCode $ P.runMultipleErrors errs
177183 in if sort expected == sort actual
178184 then Nothing
179185 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
180−
181− trim =
182− dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse