Integration.hs

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

module Skeletest.TestUtils.Integration (
  integration,

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

  -- * runTests
  runTests,
  expectSuccess,

  -- * 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 . stripControlChars . Text.strip . Text.pack
    stripControlChars s =
      case Text.breakOn "\x1b" s of
        (_, "") -> s
        (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)

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