purescript-0.15.15: tests/TestCompiler.hs

{-# LANGUAGE DoAndIfThenElse #-}

module TestCompiler where

-- Failing tests can specify the kind of error that should be thrown with a
-- @shouldFailWith declaration. For example:
--
--   "-- @shouldFailWith TypesDoNotUnify"
--
-- will cause the test to fail unless that module fails to compile with exactly
-- one TypesDoNotUnify error.
--
-- If a module is expected to produce multiple type errors, then use multiple
-- @shouldFailWith lines; for example:
--
--   -- @shouldFailWith TypesDoNotUnify
--   -- @shouldFailWith TypesDoNotUnify
--   -- @shouldFailWith TransitiveExportError
--
-- Warning and failing tests also check their output against the relative
-- golden files (`.out`). The golden files are generated automatically when
-- missing, and can be updated by setting the "HSPEC_ACCEPT" environment
-- variable, e.g. by running `HSPEC_ACCEPT=true stack test`.

import Prelude

import Language.PureScript qualified as P
import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode)

import Control.Arrow ((>>>))
import Data.ByteString qualified as BS
import Data.Function (on)
import Data.List (sort, stripPrefix, minimumBy)
import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T


import Control.Monad (forM_, when)

import System.Exit (ExitCode(..))
import System.FilePath (pathSeparator, replaceExtension, takeFileName, (</>))
import System.IO (Handle, hPutStr, hPutStrLn)
import System.IO.UTF8 (readUTF8File)

import Text.Regex.Base (RegexContext(..), RegexMaker(..))
import Text.Regex.TDFA (Regex)

import TestUtils (ExpectedModuleName(..), SupportModules, compile, createOutputFile, getTestFiles, goldenVsString, modulesDir, trim)
import Test.Hspec (Expectation, SpecWith, beforeAllWith, describe, expectationFailure, it, runIO)

spec :: SpecWith SupportModules
spec = do
  passingTests
  warningTests
  failingTests
  optimizeTests

passingTests :: SpecWith SupportModules
passingTests = do
  passingTestCases <- runIO $ getTestFiles "passing"

  describe "Passing examples" $
    beforeAllWith ((<$> createOutputFile logfile) . (,)) $
      forM_ passingTestCases $ \testPurs ->
        it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ \(support, outputFile) ->
          assertCompiles support testPurs outputFile

warningTests :: SpecWith SupportModules
warningTests = do
  warningTestCases <- runIO $ getTestFiles "warning"

  describe "Warning examples" $
    forM_ warningTestCases $ \testPurs -> do
      let mainPath = getTestMain testPurs
      it ("'" <> takeFileName mainPath <> "' should compile with expected warning(s)") $ \support -> do
        expectedWarnings <- getShouldWarnWith mainPath
        assertCompilesWithWarnings support testPurs expectedWarnings

failingTests :: SpecWith SupportModules
failingTests = do
  failingTestCases <- runIO $ getTestFiles "failing"

  describe "Failing examples" $ do
    forM_ failingTestCases $ \testPurs -> do
      let mainPath = getTestMain testPurs
      it ("'" <> takeFileName mainPath <> "' should fail to compile") $ \support -> do
        expectedFailures <- getShouldFailWith mainPath
        assertDoesNotCompile support testPurs expectedFailures

optimizeTests :: SpecWith SupportModules
optimizeTests = do
  optimizeTestCases <- runIO $ getTestFiles "optimize"

  describe "Optimization examples" $
    forM_ optimizeTestCases $ \testPurs ->
      it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile to expected output") $ \support ->
        assertCompilesToExpectedOutput support testPurs

checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation
checkShouldReport expected prettyPrintDiagnostics errs =
  let actual = map P.errorCode $ P.runMultipleErrors errs
  in if sort expected == sort (map T.unpack actual)
    then checkPositioned errs
    else expectationFailure $ "Expected these diagnostics: " ++ show expected ++ ", but got these: "
      ++ show actual ++ ", full diagnostic messages: \n"
      ++ prettyPrintDiagnostics errs

checkPositioned :: P.MultipleErrors -> Expectation
checkPositioned errs =
  case mapMaybe guardSpans (P.runMultipleErrors errs) of
    [] ->
      pure ()
    errs' ->
      expectationFailure
        $ "Found diagnostics with missing source spans:\n"
        ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs')
  where
  guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage
  guardSpans err = case P.errorSpan err of
    Just ss | not $ all isNonsenseSpan ss -> Nothing
    _ -> Just err

  isNonsenseSpan :: P.SourceSpan -> Bool
  isNonsenseSpan (P.SourceSpan spanName spanStart spanEnd) =
    spanName == "" || spanName == "<module>" || (spanStart == emptyPos && spanEnd == emptyPos)

  emptyPos :: P.SourcePos
  emptyPos = P.SourcePos 0 0

assertCompiles
  :: SupportModules
  -> [FilePath]
  -> Handle
  -> Expectation
assertCompiles support inputFiles outputFile = do
  (fileContents, (result, _)) <- compile (Just IsMain) support inputFiles
  let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }
  case result of
    Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs
    Right _ -> do
      let entryPoint = modulesDir </> "index.js"
      writeFile entryPoint "import('./Main/index.js').then(({ main }) => main());"
      nodeResult <- readNodeProcessWithExitCode Nothing [entryPoint] ""
      hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
      case nodeResult of
        Right (ExitSuccess, out, err)
          | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err
          | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out
          | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out
        Right (ExitFailure _, _, err) -> expectationFailure err
        Left err -> expectationFailure err

assertCompilesWithWarnings
  :: SupportModules
  -> [FilePath]
  -> [String]
  -> Expectation
assertCompilesWithWarnings support inputFiles shouldWarnWith = do
  (fileContents, result'@(result, warnings)) <- compile Nothing support inputFiles
  let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }
  case result of
    Left errs ->
      expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs
    Right _ -> do
      checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings errorOptions) warnings
      goldenVsString
        (replaceExtension (getTestMain inputFiles) ".out")
        (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest fileContents result')

assertDoesNotCompile
  :: SupportModules
  -> [FilePath]
  -> [String]
  -> Expectation
assertDoesNotCompile support inputFiles shouldFailWith = do
  (fileContents, result) <- compile Nothing support inputFiles
  let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }
  case fst result of
    Left errs -> do
      when (null shouldFailWith)
        (expectationFailure $
          "shouldFailWith declaration is missing (errors were: "
          ++ show (map P.errorCode (P.runMultipleErrors errs))
          ++ ")")
      checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors errorOptions) errs
      goldenVsString
        (replaceExtension (getTestMain inputFiles) ".out")
        (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest fileContents result)
    Right _ ->
      expectationFailure "Should not have compiled"

assertCompilesToExpectedOutput
  :: SupportModules
  -> [FilePath]
  -> Expectation
assertCompilesToExpectedOutput support inputFiles = do
  (fileContents, (result, _)) <- compile Nothing support inputFiles
  let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }
  case result of
    Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs
    Right _ ->
      goldenVsString
        (replaceExtension (getTestMain inputFiles) ".out.js")
        (BS.readFile $ modulesDir </> "Main/index.js")

-- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order
-- to compare it to the contents of a golden test file.
printDiagnosticsForGoldenTest :: [(FilePath, T.Text)] -> (Either P.MultipleErrors a, P.MultipleErrors) -> String
printDiagnosticsForGoldenTest fileContents (result, warnings) =
  normalizePaths $ case result of
    Left errs ->
      -- TODO: should probably include warnings when failing?
      P.prettyPrintMultipleErrors errorOptions errs
    Right _ ->
      P.prettyPrintMultipleWarnings errorOptions warnings
  where
  errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }

-- Replaces Windows-style paths in an error or warning with POSIX paths
normalizePaths :: String -> String
normalizePaths = if pathSeparator == '\\'
  then replaceMatches " [0-9A-Za-z_-]+(\\\\[0-9A-Za-z_-]+)+\\.[A-Za-z]+\\>" (map turnSlash)
  else id
  where
    turnSlash '\\' = '/'
    turnSlash c = c

-- Uses a function to replace all matches of a regular expression in a string
replaceMatches :: String -> (String -> String) -> String -> String
replaceMatches reString phi = go
  where
    re :: Regex
    re = makeRegex reString
    go :: String -> String
    go haystack =
      let (prefix, needle, suffix) = match re haystack
      in prefix ++ (if null needle then "" else phi needle ++ go suffix)

-- Takes the test entry point from a group of purs files - this is determined
-- by the file with the shortest path name, as everything but the main file
-- will be under a subdirectory.
getTestMain :: [FilePath] -> FilePath
getTestMain = minimumBy (compare `on` length)

-- Scans a file for @shouldFailWith directives in the comments, used to
-- determine expected failures
getShouldFailWith :: FilePath -> IO [String]
getShouldFailWith = extractPragma "shouldFailWith"

-- Scans a file for @shouldWarnWith directives in the comments, used to
-- determine expected warnings
getShouldWarnWith :: FilePath -> IO [String]
getShouldWarnWith = extractPragma "shouldWarnWith"

extractPragma :: String -> FilePath -> IO [String]
extractPragma pragma = fmap go . readUTF8File
  where
    go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim


logfile :: FilePath
logfile = "psc-tests.out"