Integration.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Skeletest.TestUtils.Integration (
  integration,

  -- * Test runner
  FixtureTestRunner,
  FileContents,
  setMainFile,
  addTestFile,
  readTestFile,

  -- * runTests
  runTests,
  expectCode,
  expectSuccess,
  expectFailure,

  -- * Re-exports
  ExitCode (..),
) where

import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
import Data.Text qualified as Text
import Skeletest
import System.Directory (createDirectoryIfMissing)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (</>))
import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)

data MarkerIntegration = MarkerIntegration
  deriving (Show)

instance IsMarker MarkerIntegration where
  getMarkerName _ = "integration"

integration :: Spec -> Spec
integration = markManual . withMarker MarkerIntegration

{----- runTests -----}

data FixtureTestRunner = FixtureTestRunner
  { testRunnerDir :: FilePath
  , testRunnerSettingsRef :: IORef TestRunnerSettings
  }

data TestRunnerSettings = TestRunnerSettings
  { mainFile :: FileContents
  , testFiles :: [(FilePath, FileContents)]
  }

-- | File contents as a list of lines.
type FileContents = [String]

instance Fixture FixtureTestRunner where
  fixtureAction = do
    FixtureTmpDir tmpdir <- getFixture
    settingsRef <- newIORef defaultSettings
    pure . noCleanup $
      FixtureTestRunner
        { testRunnerDir = tmpdir
        , testRunnerSettingsRef = settingsRef
        }
   where
    defaultSettings =
      TestRunnerSettings
        { mainFile = ["import Skeletest.Main"]
        , testFiles = []
        }

setMainFile :: FixtureTestRunner -> FileContents -> IO ()
setMainFile FixtureTestRunner{testRunnerSettingsRef} contents =
  modifyIORef testRunnerSettingsRef $ \settings -> settings{mainFile = contents}

addTestFile :: FixtureTestRunner -> FilePath -> FileContents -> IO ()
addTestFile FixtureTestRunner{testRunnerSettingsRef} fp contents =
  modifyIORef testRunnerSettingsRef $ \settings ->
    settings{testFiles = (fp, contents) : testFiles settings}

readTestFile :: FixtureTestRunner -> FilePath -> IO String
readTestFile FixtureTestRunner{testRunnerDir} fp = readFile $ testRunnerDir </> fp

runTests :: FixtureTestRunner -> [String] -> IO (ExitCode, String, String)
runTests FixtureTestRunner{..} args = do
  TestRunnerSettings{..} <- readIORef testRunnerSettingsRef
  addFile "Main.hs" mainFile
  mapM_ (uncurry addFile) testFiles

  (code, stdout, stderr) <-
    flip readCreateProcessWithExitCode "" $
      setCWD testRunnerDir . proc "runghc" . concat $
        [ "--" : ghcArgs
        , "--" : "Main.hs" : args
        ]

  pure (code, sanitize stdout, sanitize stderr)
 where
  addFile fp contents = do
    let path = testRunnerDir </> fp
    createDirectoryIfMissing True (takeDirectory path)
    writeFile path (unlines contents)

  ghcArgs =
    concat
      [ ["-hide-all-packages"]
      , ["-F", "-pgmF=skeletest-preprocessor"]
      , ["-package skeletest"]
      ]
  setCWD dir p = p{cwd = Just dir}

  sanitize = Text.unpack . stripOverwrites . stripControlChars . Text.strip . Text.pack
  stripOverwrites s =
    case Text.breakOn "\r" s of
      (_, "") -> s
      (pre, post) -> Text.dropWhileEnd (/= '\n') pre <> stripOverwrites (Text.drop 1 post)
  stripControlChars s =
    case Text.breakOn "\x1b" s of
      (_, "") -> s
      (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)

expectCode :: (HasCallStack) => ExitCode -> IO (ExitCode, String, String) -> IO (String, String)
expectCode expected m = do
  (code, stdout, stderr) <- m
  context (unlines ["===== stdout =====", stdout, "===== stderr =====", stderr]) $
    code `shouldBe` expected
  pure (stdout, stderr)

expectSuccess :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String)
expectSuccess = expectCode ExitSuccess

expectFailure :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String)
expectFailure = expectCode $ ExitFailure 1