hie-bios-0.20.0: tests/Utils.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Utils (
  -- * Test Environment
  TestM,
  TestEnv,
  TestConfig (..),
  defConfig,

  -- * Run Tests
  runTestEnv,
  runTestModeEnv,
  runTestEnv',
  runTestEnvLocal,

  -- * Low-level test-env modification helpers
  setCradle,
  unsetCradle,
  setLoadResult,
  unsetLoadResult,
  setLibDirResult,
  setGhcVersionResult,

  -- * Ask for test environment
  askRoot,
  askStep,
  askLogger,
  askCradle,
  askLoadMode,
  askLoadResult,
  askOrLoadLibDir,
  askLibDir,
  askLibDirResult,
  askGhcVersion,
  askGhcVersionResult,

  -- * Test setup helpers
  step,
  normFile,
  relFile,
  findCradleLoc,
  initCradle,
  initImplicitCradle,
  loadComponentOptions,
  loadRuntimeGhcLibDir,
  loadRuntimeGhcVersion,
  loadFileGhc,
  isCabalMultipleCompSupported',

  -- * Assertion helpers
  assertCradle,
  assertLibDirVersion,
  assertGhcVersion,
  assertLibDirVersionIs,
  assertGhcVersionIs,
  assertComponentOptions,
  assertCradleError,
  assertLoadSuccess,
  assertLoadFailure,
  assertLoadNone,
  assertCradleLoadSuccess,
  assertCradleLoadError,

  -- * High-level test helpers
  testDirectoryM,
  testImplicitDirectoryM,
  testImplicitDirectoryWithContextM,
  findCradleForModuleM,
) where

import qualified Colog.Core as L
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.List
import Data.Void
import qualified GHC as G
import HIE.Bios.Cradle
import HIE.Bios.Cradle.Cabal (isCabalMultipleCompSupported)
import HIE.Bios.Cradle.ProgramVersions (makeVersions)
import HIE.Bios.Environment
import HIE.Bios.Flags
import HIE.Bios.Ghc.Api
import qualified HIE.Bios.Ghc.Gap as G
import HIE.Bios.Ghc.Load
import HIE.Bios.Types as HIE
import Prettyprinter
import System.Directory
import System.FilePath
import System.IO.Temp
import Test.Tasty.HUnit
import Colog.Core
import qualified Data.Text as Text
import Data.Function ((&))
import qualified Control.Exception as C
import System.Environment (lookupEnv)

-- ---------------------------------------------------------------------------
-- Test configuration and information
-- ---------------------------------------------------------------------------

type TestM a = StateT (TestEnv Void) IO a

data TestConfig = TestConfig
  { useTemporaryDirectory :: Bool
  , testProjectRoots :: FilePath
  , testVerbose :: Bool
  , testStepFunction :: String -> IO ()
  , testLoadModeConfig :: LoadMode
  }

data TestEnv ext = TestEnv
  { testCradleType :: Maybe (Cradle ext)
  , testLoadResult :: Maybe (CradleLoadResult ComponentOptions)
  , testLibDirResult :: Maybe (CradleLoadResult FilePath)
  , testGhcVersionResult :: Maybe (CradleLoadResult String)
  , testRootDir :: FilePath
  , testLogger :: L.LogAction IO (L.WithSeverity HIE.Log)
  , testLoadMode :: LoadMode
  }

defConfig :: TestConfig
defConfig =
  TestConfig
    { useTemporaryDirectory = True
    , testProjectRoots = "./tests/projects"
    , testVerbose = False
    , testStepFunction = unLogAction logStringStderr
    , testLoadModeConfig = LoadFile
    }

runTestEnv :: FilePath -> TestM a -> TestConfig -> IO a
runTestEnv fp act testConf = runTestEnv' testConf fp act

runTestModeEnv :: FilePath -> LoadMode -> TestM a -> TestConfig -> IO a
runTestModeEnv fp loadMode act testConf = runTestEnv' testConf{testLoadModeConfig=loadMode} fp act

runTestEnvLocal :: FilePath -> TestM a -> TestConfig -> IO a
runTestEnvLocal fp act testConf = runTestEnv' testConf{useTemporaryDirectory = False} fp act

runTestEnv' :: TestConfig -> FilePath -> TestM a -> IO a
runTestEnv' config root act = do
  -- We need to copy over the directory to somewhere outside the source tree
  -- when we test, since the cabal.project/stack.yaml/hie.yaml file in the root
  -- of this repository interferes with the test cradles!
  let wrapper r cont =
        if useTemporaryDirectory config
          then do
            mkeep <- lookupEnv "KEEP_TEMP_DIRS"
            withTempCopy (mkeep == Just "true") r cont
          else cont r
      mkEnv root' =
        TestEnv
          { testCradleType = Nothing
          , testLoadResult = Nothing
          , testLibDirResult = Nothing
          , testGhcVersionResult = Nothing
          , testRootDir = root'
          , testLogger = init_logger
          , testLoadMode = testLoadModeConfig config
          }
  realRoot <- makeAbsolute $ testProjectRoots config </> root
  wrapper realRoot $ \root' -> flip evalStateT (mkEnv root') $ do
    step $ "Run test in: " <> root'
    act
  where
    init_logger = LogAction (testStepFunction config)
      & L.cmap printLog
      & L.filterBySeverity (if testVerbose config then Debug else Error) getSeverity
    printLog (L.WithSeverity l sev) = "[" ++ show sev ++ "] " ++ show (pretty l)

-- ---------------------------------------------------------------------------
-- Modification helpers
-- ---------------------------------------------------------------------------

setCradle :: Cradle Void -> TestM ()
setCradle crd = modify' (\env -> env{testCradleType = Just crd})

unsetCradle :: TestM ()
unsetCradle = modify' (\env -> env{testCradleType = Nothing})

setLoadResult :: CradleLoadResult ComponentOptions -> TestM ()
setLoadResult clr = modify' (\env -> env{testLoadResult = Just clr})

unsetLoadResult :: TestM ()
unsetLoadResult = modify' (\env -> env{testLoadResult = Nothing})

setLibDirResult :: CradleLoadResult FilePath -> TestM ()
setLibDirResult libdir = modify' (\env -> env{testLibDirResult = Just libdir})

setGhcVersionResult :: CradleLoadResult String -> TestM ()
setGhcVersionResult ghcVersion = modify' (\env -> env{testGhcVersionResult = Just ghcVersion})

-- ---------------------------------------------------------------------------
-- Access the Test Environment
-- ---------------------------------------------------------------------------

askRoot :: TestM FilePath
askRoot = gets testRootDir

askStep :: TestM (String -> IO ())
askStep = do
  logger <- gets testLogger
  pure $ \s ->
    logger <& LogAny (Text.pack s) `WithSeverity` Info

askCradle :: TestM (Cradle Void)
askCradle =
  gets testCradleType >>= \case
    Just crd -> pure crd
    Nothing ->
      liftIO $
        assertFailure
          "No Cradle set, use 'initCradle' or 'initImplicitCradle' before asking for it"

askLoadResult :: TestM (CradleLoadResult ComponentOptions)
askLoadResult =
  gets testLoadResult >>= \case
    Just crd -> pure crd
    Nothing ->
      liftIO $
        assertFailure
          "No CradleLoadResult set, use 'loadComponent' before asking for it"

askOrLoadLibDir :: TestM FilePath
askOrLoadLibDir =
  gets testLibDirResult >>= \case
    Just lrLibDir ->
      assertCradleLoadSuccess lrLibDir
    Nothing -> do
      loadRuntimeGhcLibDir
      askLibDir

askLibDir :: TestM FilePath
askLibDir = do
  assertCradleLoadSuccess =<< askLibDirResult

askLibDirResult :: TestM (CradleLoadResult FilePath)
askLibDirResult =
  gets testLibDirResult >>= \case
    Just lrLibDir -> pure lrLibDir
    Nothing ->
      liftIO $
        assertFailure
          "No Lib Dir set, use 'loadRuntimeGhcLibDir' before asking for it"

askGhcVersion :: TestM String
askGhcVersion = do
  assertCradleLoadSuccess =<< askGhcVersionResult

askGhcVersionResult :: TestM (CradleLoadResult String)
askGhcVersionResult =
  gets testGhcVersionResult >>= \case
    Just lrGhcVersion -> pure lrGhcVersion
    Nothing ->
      liftIO $
        assertFailure
          "No GHC version set, use 'loadRuntimeGhcVersion' before asking for it"

askLogger :: TestM (L.LogAction IO (L.WithSeverity HIE.Log))
askLogger = gets testLogger

askLoadMode :: TestM LoadMode
askLoadMode = gets testLoadMode

-- ---------------------------------------------------------------------------
-- Test setup helpers
-- ---------------------------------------------------------------------------

step :: String -> TestM ()
step msg = do
  s <- askStep
  liftIO $ s msg

normFile :: FilePath -> TestM FilePath
normFile fp = (</> fp) <$> gets testRootDir

relFile :: FilePath -> TestM FilePath
relFile fp = (`makeRelative` fp) <$> gets testRootDir

findCradleLoc :: FilePath -> TestM (Maybe FilePath)
findCradleLoc fp = do
  a_fp <- normFile fp
  liftIO $ findCradle a_fp

initCradle :: FilePath -> TestM ()
initCradle fp = do
  a_fp <- normFile fp
  step $ "Finding Cradle for: " <> fp
  mcfg <- findCradleLoc a_fp
  relMcfg <- traverse relFile mcfg
  step $ "Loading Cradle: " <> show relMcfg
  logger <- askLogger
  crd <- case mcfg of
    Just cfg -> liftIO $ loadCradle logger cfg
    Nothing -> liftIO $ loadImplicitCradle logger a_fp
  step $ "Cradle: " ++ show crd
  setCradle crd

initImplicitCradle :: FilePath -> TestM ()
initImplicitCradle fp = do
  a_fp <- normFile fp
  step $ "Loading implicit Cradle for: " <> fp
  logger <- askLogger
  crd <- liftIO $ loadImplicitCradle logger a_fp
  setCradle crd

loadComponentOptions :: FilePath -> [FilePath] -> TestM ()
loadComponentOptions fp extraFps = do
  a_fp <- normFile fp
  a_fps <- traverse normFile extraFps
  crd <- askCradle
  mode <- askLoadMode
  step $ "Initialise flags for " <> fp <> " using " <> show mode
  when (not $ null extraFps) $ do
    step $ "Provided context: " <> show extraFps
  clr <- liftIO $ getCompilerOptions (TargetWithContext a_fp a_fps) mode crd
  setLoadResult clr

loadRuntimeGhcLibDir :: TestM ()
loadRuntimeGhcLibDir = do
  crd <- askCradle
  step "Load run-time ghc libdir"
  libdirRes <- liftIO $ getRuntimeGhcLibDir crd
  setLibDirResult libdirRes

loadRuntimeGhcVersion :: TestM ()
loadRuntimeGhcVersion = do
  crd <- askCradle
  step "Load run-time ghc version"
  ghcVersionRes <- liftIO $ getRuntimeGhcVersion crd
  setGhcVersionResult ghcVersionRes

isCabalMultipleCompSupported' :: TestM Bool
isCabalMultipleCompSupported' = do
  cr <- askCradle
  root <- askRoot
  versions <- liftIO $ makeVersions (cradleLogger cr) root ((runGhcCmd . cradleOptsProg) cr)
  liftIO $ isCabalMultipleCompSupported versions

loadFileGhc :: FilePath -> [FilePath] -> TestM ()
loadFileGhc fp extraFps = do
  libdir <- askOrLoadLibDir
  a_fp <- normFile fp
  stepF <- askStep
  step "Cradle load"
  loadComponentOptions fp extraFps
  opts <- assertLoadSuccess
  liftIO $
    G.runGhc (Just libdir) $ do
      let (ini, _) = initSessionWithMessage' True (Just G.batchMsg) opts
      sf <- ini
      case sf of
        -- Test resetting the targets
        Succeeded -> do
          liftIO $ stepF "Set target files"
          setTargetFiles mempty [(a_fp, a_fp)]
        Failed -> liftIO $ assertFailure "Module loading failed"

-- ---------------------------------------------------------------------------
-- Assertion helpers for hie-bios
-- ---------------------------------------------------------------------------

assertCradle :: (Cradle Void -> Bool) -> TestM ()
assertCradle cradlePred = do
  crd <- askCradle
  liftIO $ cradlePred crd @? "Must be the correct kind of cradle, got " ++ show (actionName $ cradleOptsProg crd)

assertLibDirVersion :: TestM ()
assertLibDirVersion = assertLibDirVersionIs VERSION_ghc

assertGhcVersion :: TestM ()
assertGhcVersion = assertGhcVersionIs VERSION_ghc

assertLibDirVersionIs :: String -> TestM ()
assertLibDirVersionIs ghcVersion = do
  step $ "Verify runtime GHC library directory is: " <> ghcVersion
  libdir <- askLibDir
  liftIO $
    ghcVersion `isInfixOf` libdir @? "Expected \"" <> ghcVersion
      <> "\" to be infix of: "
      <> libdir

assertGhcVersionIs :: String -> TestM ()
assertGhcVersionIs expectedVersion = do
  step $ "Verify runtime GHC version is: " <> expectedVersion
  ghcVersion <- askGhcVersion
  liftIO $ ghcVersion @?= expectedVersion

assertComponentOptions :: (ComponentOptions -> Assertion) -> TestM ()
assertComponentOptions cont = do
  opts <- assertLoadSuccess
  liftIO $ cont opts

assertCradleError :: (CradleError -> Assertion) -> TestM ()
assertCradleError cont = do
  err <- assertLoadFailure
  liftIO $ cont err

assertLoadSuccess :: TestM ComponentOptions
assertLoadSuccess = do
  askLoadResult >>= \case
    CradleSuccess opts -> pure opts
    other -> liftIO $ assertFailure $ "Expected CradleSuccess but got: " <> show other

assertLoadFailure :: TestM CradleError
assertLoadFailure = do
  askLoadResult >>= \case
    CradleFail err -> pure err
    other -> liftIO $ assertFailure $ "Expected CradleFail but got: " <> show other

assertLoadNone :: TestM ()
assertLoadNone = do
  askLoadResult >>= \case
    CradleNone -> pure ()
    other -> liftIO $ assertFailure $ "Expected CradleNone but got: " <> show other

assertCradleLoadSuccess :: CradleLoadResult a -> TestM a
assertCradleLoadSuccess = \case
  (CradleSuccess x) -> pure x
  CradleNone -> liftIO $ assertFailure "Unexpected none-Cradle"
  (CradleFail (CradleError _deps _ex stde _err_loading_files)) ->
    liftIO $ assertFailure ("Unexpected cradle fail" <> unlines stde)

assertCradleLoadError :: CradleLoadResult a -> TestM CradleError
assertCradleLoadError = \case
  (CradleSuccess _) -> liftIO $ assertFailure "Unexpected CradleSuccess"
  CradleNone -> liftIO $ assertFailure "Unexpected none-Cradle"
  (CradleFail err) -> pure err

-- ---------------------------------------------------------------------------
-- High-level, re-usable assertions
-- ---------------------------------------------------------------------------

testDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM ()
testDirectoryM cradlePred file = do
  initCradle file
  assertCradle cradlePred
  loadRuntimeGhcLibDir
  assertLibDirVersion
  loadRuntimeGhcVersion
  assertGhcVersion
  loadFileGhc file []

testImplicitDirectoryM :: (Cradle Void -> Bool) -> FilePath -> TestM ()
testImplicitDirectoryM cradlePred file = testImplicitDirectoryWithContextM cradlePred file []

testImplicitDirectoryWithContextM :: (Cradle Void -> Bool) -> FilePath -> [FilePath] -> TestM ()
testImplicitDirectoryWithContextM cradlePred file ctxt = do
  initImplicitCradle file
  assertCradle cradlePred
  loadRuntimeGhcLibDir
  assertLibDirVersion
  loadRuntimeGhcVersion
  assertGhcVersion
  loadFileGhc file ctxt

findCradleForModuleM :: FilePath -> Maybe FilePath -> TestM ()
findCradleForModuleM fp expected' = do
  rootFp <- askRoot
  let expected = fmap (rootFp </>) expected'
  crd <- findCradleLoc fp
  liftIO $ crd @?= expected

-- ---------------------------------------------------------------------------
-- Copy Directory system utilities
-- ---------------------------------------------------------------------------

withTempCopy :: Bool -> FilePath -> (FilePath -> IO a) -> IO a
withTempCopy keep srcDir f = getCanonicalTemporaryDirectory >>= \targetDir -> do
  C.bracket
    (liftIO (createTempDirectory targetDir template))
    cleanup $ \newDir -> do
      exists <- doesDirectoryExist srcDir
      when exists $ do
        copyDir srcDir newDir
      f newDir
  where
    template = "hie-bios-test"
    cleanup dir | keep = return ()
       | otherwise = (liftIO . ignoringIOErrors . removeDirectoryRecursive) dir
    ignoringIOErrors ioe = ioe `C.catch` (\e -> const (return ()) (e :: IOError))


copyDir :: FilePath -> FilePath -> IO ()
copyDir src dst = do
  contents <- listDirectory src
  forM_ contents $ \file -> do
    unless (file `elem` ignored) $ do
      let srcFp = src </> file
          dstFp = dst </> file
      isDir <- doesDirectoryExist srcFp
      if isDir
        then createDirectory dstFp >> copyDir srcFp dstFp
        else copyFile srcFp dstFp
 where
  ignored = ["dist", "dist-newstyle", ".stack-work"]