@@ -26,8 +26,9 @@ import Prelude.Compat
26import qualified Language.PureScript as P
26import qualified Language.PureScript as P
28import Data.Char (isSpace)
28import Data.Char (isSpace)
29+import Data.Function (on)
30+import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, partition)
29import Data.Maybe (mapMaybe)
31import Data.Maybe (mapMaybe)
30−import Data.List (isSuffixOf, sort, stripPrefix, intercalate)
31import Data.Time.Clock (UTCTime())
32import Data.Time.Clock (UTCTime())
33import qualified Data.Map as M
34import qualified Data.Map as M
@@ -55,39 +56,75 @@ main = hspec spec
56spec :: Spec
57spec :: Spec
58− (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) <- runIO $ do
59− cwd <- getCurrentDirectory
61− let supportDir = cwd </> "tests" </> "support" </> "bower_components"
62− let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
64− supportPurs <- supportFiles "purs"
65− supportJS <- supportFiles "js"
67− foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
68− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
60+ (supportPurs, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do
61+ cwd <- getCurrentDirectory
70 let passing = cwd </> "examples" </> "passing"
62 let passing = cwd </> "examples" </> "passing"
71− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
73 let failing = cwd </> "examples" </> "failing"
63 let failing = cwd </> "examples" </> "failing"
74− failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
64+ let supportDir = cwd </> "tests" </> "support" </> "bower_components"
75−
65+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
76− return (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases)
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)
78 context ("Passing examples") $ do
72 context ("Passing examples") $ do
79− forM_ passingTestCases $ \inputFile ->
73+ forM_ passingTestCases $ \(testPurs, testJS) ->
80− it ("'" <> inputFile <> "' should compile and run without error") $ do
74+ it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do
75+ testForeigns <- loadForeigns testJS
81− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
76+ assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns)
83 context ("Failing examples") $ do
78 context ("Failing examples") $ do
84− forM_ failingTestCases $ \inputFile -> do
79+ forM_ failingTestCases $ \(testPurs, testJS) -> do
80+ let mainPath = getTestMain testPurs
85− expectedFailures <- runIO $ getShouldFailWith (failing </> inputFile)
81+ expectedFailures <- runIO $ getShouldFailWith mainPath
86− it ("'" <> inputFile <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
82+ it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
83+ testForeigns <- loadForeigns testJS
87− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns expectedFailures
84+ assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures
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
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
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)
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)
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
120+ let dir = takeDirectory fp
121+ ext = reverse ".purs"
123+ then maybe fp reverse $ stripPrefix ext $ reverse fp
126+ -- Scans a file for @shouldFailWith directives in the comments, used to
127+ -- determine expected failures
91 getShouldFailWith :: FilePath -> IO [String]
128 getShouldFailWith :: FilePath -> IO [String]
92 getShouldFailWith = fmap extractFailWiths . readUTF8File
129 getShouldFailWith = fmap extractFailWiths . readUTF8File