@@ -26,8 +26,9 @@ import Prelude.Compat
2626import qualified Language.PureScript as P
2727
2828import Data.Char (isSpace)
29+import Data.Function (on)
30+import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, partition)
2931import Data.Maybe (mapMaybe)
30−import Data.List (isSuffixOf, sort, stripPrefix, intercalate)
3132import Data.Time.Clock (UTCTime())
3233
3334import qualified Data.Map as M
@@ -55,39 +56,75 @@ main = hspec spec
5556
5657spec :: Spec
5758spec = do
58− (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) <- runIO $ do
59− cwd <- getCurrentDirectory
60−
61− let supportDir = cwd </> "tests" </> "support" </> "bower_components"
62− let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
63−
64− supportPurs <- supportFiles "purs"
65− supportJS <- supportFiles "js"
66−
67− foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
68− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
6959
60+ (supportPurs, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do
61+ cwd <- getCurrentDirectory
7062 let passing = cwd </> "examples" </> "passing"
71− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
72−
7363 let failing = cwd </> "examples" </> "failing"
74− failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
75−
76− return (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases)
64+ let supportDir = cwd </> "tests" </> "support" </> "bower_components"
65+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
66+ passingFiles <- getTestFiles passing <$> testGlob passing
67+ failingFiles <- getTestFiles failing <$> testGlob failing
68+ supportPurs <- supportFiles "purs"
69+ supportForeigns <- loadForeigns =<< supportFiles "js"
70+ return (supportPurs, supportForeigns, passingFiles, failingFiles)
7771
7872 context ("Passing examples") $ do
79− forM_ passingTestCases $ \inputFile ->
80− it ("'" <> inputFile <> "' should compile and run without error") $ do
81− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
73+ forM_ passingTestCases $ \(testPurs, testJS) ->
74+ it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do
75+ testForeigns <- loadForeigns testJS
76+ assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns)
8277
8378 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
79+ forM_ failingTestCases $ \(testPurs, testJS) -> do
80+ let mainPath = getTestMain testPurs
81+ expectedFailures <- runIO $ getShouldFailWith mainPath
82+ it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
83+ testForeigns <- loadForeigns testJS
84+ assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures
8885
8986 where
9087
88+ -- A glob for all purs and js files within a test directory
89+ testGlob :: FilePath -> IO [FilePath]
90+ testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir
91+
92+ -- Loads foreign modules from source files
93+ loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath)
94+ loadForeigns paths = do
95+ files <- forM paths (\f -> (f,) <$> readUTF8File f)
96+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files
97+ return foreigns
98+
99+ -- Groups the test files so that a top-level file can have dependencies in a
100+ -- subdirectory of the same name. The inner tuple contains a list of the
101+ -- .purs files and the .js files for the test case.
102+ getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])]
103+ getTestFiles baseDir
104+ = map (partition ((== ".purs") . takeExtensions))
105+ . map (map (baseDir </>))
106+ . groupBy ((==) `on` extractPrefix)
107+ . sortBy (compare `on` extractPrefix)
108+ . map (makeRelative baseDir)
109+
110+ -- Takes the test entry point from a group of purs files - this is determined
111+ -- by the file with the shortest path name, as everything but the main file
112+ -- will be under a subdirectory.
113+ getTestMain :: [FilePath] -> FilePath
114+ getTestMain = head . sortBy (compare `on` length)
115+
116+ -- Extracts the filename part of a .purs file, or if the file is in a
117+ -- subdirectory, the first part of that directory path.
118+ extractPrefix :: FilePath -> FilePath
119+ extractPrefix fp =
120+ let dir = takeDirectory fp
121+ ext = reverse ".purs"
122+ in if dir == "."
123+ then maybe fp reverse $ stripPrefix ext $ reverse fp
124+ else dir
125+
126+ -- Scans a file for @shouldFailWith directives in the comments, used to
127+ -- determine expected failures
91128 getShouldFailWith :: FilePath -> IO [String]
92129 getShouldFailWith = fmap extractFailWiths . readUTF8File
93130 where