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