1{-# LANGUAGE DoAndIfThenElse #-} 2 3module TestCompiler where 4 5-- Failing tests can specify the kind of error that should be thrown with a 6-- @shouldFailWith declaration. For example: 7-- 8-- "-- @shouldFailWith TypesDoNotUnify" 9-- 10-- will cause the test to fail unless that module fails to compile with exactly 11-- one TypesDoNotUnify error. 12-- 13-- If a module is expected to produce multiple type errors, then use multiple 14-- @shouldFailWith lines; for example: 15-- 16-- -- @shouldFailWith TypesDoNotUnify 17-- -- @shouldFailWith TypesDoNotUnify 18-- -- @shouldFailWith TransitiveExportError 19-- 20-- Warning and failing tests also check their output against the relative 21-- golden files (`.out`). The golden files are generated automatically when 22-- missing, and can be updated by setting the "HSPEC_ACCEPT" environment 23-- variable, e.g. by running `HSPEC_ACCEPT=true stack test`. 24 25import Prelude () 26import Prelude.Compat 27 28import qualified Language.PureScript as P 29 30import Control.Arrow ((>>>)) 31import Data.Function (on) 32import Data.List (sort, stripPrefix, minimumBy) 33import Data.Maybe (mapMaybe) 34import qualified Data.Text as T 35import qualified Data.Text.Encoding as T 36 37 38import Control.Monad 39 40import System.Exit 41import System.Process 42import System.FilePath 43import System.IO 44import System.IO.UTF8 (readUTF8File) 45 46import Text.Regex.Base 47import Text.Regex.TDFA (Regex) 48 49import TestUtils 50import Test.Hspec 51 52spec :: SpecWith SupportModules 53spec = do 54 passingTests 55 warningTests 56 failingTests 57 58passingTests :: SpecWith SupportModules 59passingTests = do 60 passingTestCases <- runIO $ getTestFiles "passing" 61 62 describe "Passing examples" $ 63 beforeAllWith ((<$> createOutputFile logfile) . (,)) $ 64 forM_ passingTestCases $ \testPurs -> 65 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ \(support, outputFile) -> 66 assertCompiles support testPurs outputFile 67 68warningTests :: SpecWith SupportModules 69warningTests = do 70 warningTestCases <- runIO $ getTestFiles "warning" 71 72 describe "Warning examples" $ 73 forM_ warningTestCases $ \testPurs -> do 74 let mainPath = getTestMain testPurs 75 it ("'" <> takeFileName mainPath <> "' should compile with expected warning(s)") $ \support -> do 76 expectedWarnings <- getShouldWarnWith mainPath 77 assertCompilesWithWarnings support testPurs expectedWarnings 78 79failingTests :: SpecWith SupportModules 80failingTests = do 81 failingTestCases <- runIO $ getTestFiles "failing" 82 83 describe "Failing examples" $ do 84 forM_ failingTestCases $ \testPurs -> do 85 let mainPath = getTestMain testPurs 86 it ("'" <> takeFileName mainPath <> "' should fail to compile") $ \support -> do 87 expectedFailures <- getShouldFailWith mainPath 88 assertDoesNotCompile support testPurs expectedFailures 89 90checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation 91checkShouldReport expected prettyPrintDiagnostics errs = 92 let actual = map P.errorCode $ P.runMultipleErrors errs 93 in if sort expected == sort (map T.unpack actual) 94 then checkPositioned errs 95 else expectationFailure $ "Expected these diagnostics: " ++ show expected ++ ", but got these: " 96 ++ show actual ++ ", full diagnostic messages: \n" 97 ++ prettyPrintDiagnostics errs 98 99checkPositioned :: P.MultipleErrors -> Expectation 100checkPositioned errs = 101 case mapMaybe guardSpans (P.runMultipleErrors errs) of 102 [] -> 103 pure () 104 errs' -> 105 expectationFailure 106 $ "Found diagnostics with missing source spans:\n" 107 ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs') 108 where 109 guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage 110 guardSpans err = case P.errorSpan err of 111 Just ss | not $ all isNonsenseSpan ss -> Nothing 112 _ -> Just err 113 114 isNonsenseSpan :: P.SourceSpan -> Bool 115 isNonsenseSpan (P.SourceSpan spanName spanStart spanEnd) = 116 spanName == "" || spanName == "<module>" || (spanStart == emptyPos && spanEnd == emptyPos) 117 118 emptyPos :: P.SourcePos 119 emptyPos = P.SourcePos 0 0 120 121assertCompiles 122 :: SupportModules 123 -> [FilePath] 124 -> Handle 125 -> Expectation 126assertCompiles support inputFiles outputFile = do 127 (result, _) <- compile support inputFiles 128 case result of 129 Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs 130 Right _ -> do 131 process <- findNodeProcess 132 let entryPoint = modulesDir </> "index.js" 133 writeFile entryPoint "require('Main').main()" 134 nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process 135 hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" 136 case nodeResult of 137 Just (ExitSuccess, out, err) 138 | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err 139 | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out 140 | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out 141 Just (ExitFailure _, _, err) -> expectationFailure err 142 Nothing -> expectationFailure "Couldn't find node.js executable" 143 144assertCompilesWithWarnings 145 :: SupportModules 146 -> [FilePath] 147 -> [String] 148 -> Expectation 149assertCompilesWithWarnings support inputFiles shouldWarnWith = do 150 result'@(result, warnings) <- compile support inputFiles 151 case result of 152 Left errs -> 153 expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs 154 Right _ -> do 155 checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings 156 goldenVsString 157 (replaceExtension (getTestMain inputFiles) ".out") 158 (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result') 159 160assertDoesNotCompile 161 :: SupportModules 162 -> [FilePath] 163 -> [String] 164 -> Expectation 165assertDoesNotCompile support inputFiles shouldFailWith = do 166 result <- compile support inputFiles 167 case fst result of 168 Left errs -> do 169 when (null shouldFailWith) 170 (expectationFailure $ 171 "shouldFailWith declaration is missing (errors were: " 172 ++ show (map P.errorCode (P.runMultipleErrors errs)) 173 ++ ")") 174 checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs 175 goldenVsString 176 (replaceExtension (getTestMain inputFiles) ".out") 177 (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result) 178 Right _ -> 179 expectationFailure "Should not have compiled" 180 181-- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order 182-- to compare it to the contents of a golden test file. 183printDiagnosticsForGoldenTest :: (Either P.MultipleErrors a, P.MultipleErrors) -> String 184printDiagnosticsForGoldenTest (result, warnings) = 185 normalizePaths $ case result of 186 Left errs -> 187 -- TODO: should probably include warnings when failing? 188 P.prettyPrintMultipleErrors P.defaultPPEOptions errs 189 Right _ -> 190 P.prettyPrintMultipleWarnings P.defaultPPEOptions warnings 191 192-- Replaces Windows-style paths in an error or warning with POSIX paths 193normalizePaths :: String -> String 194normalizePaths = if pathSeparator == '\\' 195 then replaceMatches " [0-9A-Za-z_-]+(\\\\[0-9A-Za-z_-]+)+\\.[A-Za-z]+\\>" (map turnSlash) 196 else id 197 where 198 turnSlash '\\' = '/' 199 turnSlash c = c 200 201-- Uses a function to replace all matches of a regular expression in a string 202replaceMatches :: String -> (String -> String) -> String -> String 203replaceMatches reString phi = go 204 where 205 re :: Regex 206 re = makeRegex reString 207 go :: String -> String 208 go haystack = 209 let (prefix, needle, suffix) = match re haystack 210 in prefix ++ (if null needle then "" else phi needle ++ go suffix) 211 212-- Takes the test entry point from a group of purs files - this is determined 213-- by the file with the shortest path name, as everything but the main file 214-- will be under a subdirectory. 215getTestMain :: [FilePath] -> FilePath 216getTestMain = minimumBy (compare `on` length) 217 218-- Scans a file for @shouldFailWith directives in the comments, used to 219-- determine expected failures 220getShouldFailWith :: FilePath -> IO [String] 221getShouldFailWith = extractPragma "shouldFailWith" 222 223-- Scans a file for @shouldWarnWith directives in the comments, used to 224-- determine expected warnings 225getShouldWarnWith :: FilePath -> IO [String] 226getShouldWarnWith = extractPragma "shouldWarnWith" 227 228extractPragma :: String -> FilePath -> IO [String] 229extractPragma pragma = fmap go . readUTF8File 230 where 231 go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim 232 233 234logfile :: FilePath 235logfile = "psc-tests.out" 236