hie-bios 0.10.0 → 0.11.0

raw patch · 12 files changed

+763/−350 lines, 12 filesdep ~aesondep ~ghcdep ~prettyprinterPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, ghc, prettyprinter, transformers, unix-compat, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• hie-bios.cabal +6/−4
• src/HIE/Bios.hs +0/−0
• src/HIE/Bios/Config/YAML.hs +20/−0
• src/HIE/Bios/Environment.hs +1/−1
• src/HIE/Bios/Ghc/Api.hs +3/−1
• src/HIE/Bios/Ghc/Check.hs +1/−0
• src/HIE/Bios/Ghc/Gap.hs +42/−7
• src/HIE/Bios/Ghc/Load.hs +11/−4
• src/HIE/Bios/Ghc/Logger.hs +27/−2
• tests/BiosTests.hs +205/−331
• tests/Utils.hs +439/−0

@@ -1,5 +1,13 @@ # ChangeLog hie-bios +## 2022-09-13 - 0.11.0++* Compatibility with aeson 1.5 [#368](https://github.com/haskell/hie-bios/pull/368)+* Add GHC 9.4 support [#366](https://github.com/haskell/hie-bios/pull/366)+* Actually run the bios-tests when tool-deps are ignored [#365](https://github.com/haskell/hie-bios/pull/365)+  * They have been accidentally disabled since 0.9.0.+* Completely overhaul test-suite [#356](https://github.com/haskell/hie-bios/pull/356)+ ## 2022-07-26 - 0.10.0  * Apply Hlint suggestions [#354](https://github.com/haskell/hie-bios/pull/354)

@@ -1,6 +1,6 @@ Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.10.0+Version:                0.11.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> License:                BSD-3-Clause@@ -125,7 +125,7 @@                         tests/projects/stack-with-yaml/stack-with-yaml.cabal                         tests/projects/stack-with-yaml/src/Lib.hs -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.0.2 || ==9.2.1 || ==9.2.1+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 || ==9.2.4  Library   Default-Language:     Haskell2010@@ -150,7 +150,7 @@   autogen-modules:      Paths_hie_bios   Build-Depends:                         base                 >= 4.8 && < 5,-                        aeson                >= 1.4.5 && < 2.1,+                        aeson                >= 1.5 && < 2.2,                         base16-bytestring    >= 0.1.1 && < 1.1,                         bytestring           >= 0.10.8 && < 0.12,                         co-log-core          ^>= 0.3.0,@@ -164,7 +164,7 @@                         extra                >= 1.6.14 && < 1.8,                         prettyprinter        ^>= 1.7.0,                         process              >= 1.6.1 && < 1.7,-                        ghc                  >= 8.6.1 && < 9.3,+                        ghc                  >= 8.6.1 && < 9.5,                         transformers         >= 0.5.2 && < 0.7,                         temporary            >= 1.2 && < 1.4,                         text                 >= 1.2.3 && < 2.1,@@ -216,6 +216,7 @@   build-depends:       base,       extra,+      transformers,       tasty,       tasty-hunit,       tasty-expected-failure,@@ -229,6 +230,7 @@   hs-source-dirs: tests/   ghc-options: -threaded -Wall   main-is: BiosTests.hs+  other-modules: Utils  Source-Repository head   Type:                 git

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE CPP                   #-}  -- | Datatypes for parsing @hie.yaml@ files module HIE.Bios.Config.YAML@@ -22,12 +23,31 @@  import           Control.Applicative ((<|>)) import           Data.Aeson+#if MIN_VERSION_aeson(2,0,0) import           Data.Aeson.KeyMap   (keys)+#else+import qualified Data.HashMap.Strict as Map+import qualified Data.Text           as T+#endif import           Data.Aeson.Types    (Object, Parser, Value (Null),                                       typeMismatch) import qualified Data.Char           as C (toLower) import           Data.List           ((\\)) import           GHC.Generics        (Generic)++#if !MIN_VERSION_aeson(2,0,0)+-- | Backwards compatible type-def for Key+-- This used to be just a Text, but since aeson >= 2+-- this is an opaque datatype.+type Key = T.Text+-- | Backwards compatible type-def for KeyMap+-- This used to be just a HashMap, but since aeson >= 2+-- this is an opaque datatype.+type KeyMap v = Map.HashMap T.Text v+ +keys :: KeyMap v -> [Key]+keys = Map.keys+#endif  checkObjectKeys :: [Key] -> Object -> Parser () checkObjectKeys allowedKeys obj =

@@ -150,7 +150,7 @@   let leftovers = map G.unLoc leftovers' ++ additionalTargets    let (df3, srcs, _objs) = Gap.parseTargetFiles df2 leftovers-  ts <- mapM (uncurry Gap.guessTarget) srcs+  ts <- mapM (uncurry (\f phase -> Gap.guessTarget f (Just $ Gap.homeUnitId_ df3) phase) ) srcs   return (df3, ts)  -- | Make filepaths in the given 'DynFlags' absolute.

@@ -5,6 +5,8 @@   , initializeFlagsWithCradleWithMessage   , G.SuccessFlag(..)   , withDynFlags+  -- For test purposes+  , initSessionWithMessage   ) where  import GHC (LoadHowMuch(..), DynFlags, GhcMonad)@@ -62,7 +64,7 @@     G.setTargets targets     -- Get the module graph using the function `getModuleGraph`     mod_graph <- G.depanal [] True-    G.load' LoadAllTargets msg mod_graph, compOpts)+    Gap.load' Nothing LoadAllTargets msg mod_graph, compOpts)  ---------------------------------------------------------------- 

@@ -93,3 +93,4 @@         df <- G.getSessionDynFlags         (df', _) <- addCmdOpts ["-Wall"] df         return $ G.warningFlags df'+

@@ -57,6 +57,9 @@   , mapMG   , mgModSummaries   , unsetLogAction+  , load'+  , homeUnitId_+  , getDynFlags   ) where  import Control.Monad.IO.Class@@ -69,7 +72,7 @@ import Data.List import System.FilePath -import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay')+import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay', getDynFlags) import qualified DynFlags as G import qualified Exception as G @@ -143,10 +146,37 @@ import GHC.Utils.Outputable import qualified GHC.Utils.Ppr as Ppr #endif+#if __GLASGOW_HASKELL__ >= 900+import GHC.Unit.Types (UnitId)+#endif +#if __GLASGOW_HASKELL__ >= 900+import qualified GHC.Driver.Main as G+import qualified GHC.Driver.Make as G+#else+import qualified HscMain as G+import qualified GhcMake as G+#endif+ ghcVersion :: String ghcVersion = VERSION_ghc +#if __GLASGOW_HASKELL__ <= 810+homeUnitId_ :: a -> ()+homeUnitId_ = const ()+#elif __GLASGOW_HASKELL__ <= 901+homeUnitId_ :: DynFlags -> UnitId+homeUnitId_ = homeUnitId+#endif++#if __GLASGOW_HASKELL__ >= 904+load' :: GhcMonad m => Maybe G.ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' = G.load'+#else+load' :: GhcMonad m => a -> LoadHowMuch -> Maybe G.Messager -> ModuleGraph -> m SuccessFlag+load' _ a b c = G.load' a b c+#endif+ #if __GLASGOW_HASKELL__ >= 900 bracket :: E.MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b bracket =@@ -211,11 +241,12 @@  ---------------------------------------------------------------- -guessTarget :: GhcMonad m => String -> Maybe G.Phase -> m G.Target-#if __GLASGOW_HASKELL__ >= 901-guessTarget a b = G.guessTarget a b+#if __GLASGOW_HASKELL__ >= 903+guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe G.Phase -> m G.Target+guessTarget a b c = G.guessTarget a b c #else-guessTarget a b = G.guessTarget a b+guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target+guessTarget a _ b = G.guessTarget a b #endif  ----------------------------------------------------------------@@ -309,7 +340,9 @@ #endif  noopLogger :: LogAction-#if __GLASGOW_HASKELL__ >= 900+#if __GLASGOW_HASKELL__ >= 903+noopLogger = (\_wr _s _ss _m -> return ())+#elif __GLASGOW_HASKELL__ >= 900 noopLogger = (\_df _wr _s _ss _m -> return ()) #else noopLogger = (\_df _wr _s _ss _pp _m -> return ())@@ -335,7 +368,9 @@ -- --------------------------------------------------------  numLoadedPlugins :: HscEnv -> Int-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 903+numLoadedPlugins = length . Plugins.pluginsWithArgs . hsc_plugins+#elif __GLASGOW_HASKELL__ >= 902 numLoadedPlugins = length . Plugins.plugins #elif __GLASGOW_HASKELL__ >= 808 numLoadedPlugins = length . Plugins.plugins . hsc_dflags

@@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -- | Convenience functions for loading a file into a GHC API session-module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage, Log (..)) where+module HIE.Bios.Ghc.Load  where   import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))@@ -26,6 +26,7 @@ #endif  import qualified HIE.Bios.Ghc.Gap as Gap+import GHC.Fingerprint  data Log =   LogLoaded FilePath FilePath@@ -120,7 +121,12 @@ updateTime ts graph = liftIO $ do   cur_time <- getCurrentTime   let go ms-        | any (msTargetIs ms) ts = ms {ms_hs_date = cur_time}+        | any (msTargetIs ms) ts =+#if __GLASGOW_HASKELL__ >= 903+            ms {ms_hs_hash = fingerprint0}+#else+            ms {ms_hs_date = cur_time}+#endif         | otherwise = ms   pure $ Gap.mapMG go graph @@ -138,7 +144,7 @@     G.setTargets targets     mod_graph <- updateTime targets =<< depanal [] False     liftIO $ logger <& LogModGraph mod_graph `WithSeverity` Debug-    void $ G.load' LoadAllTargets msg mod_graph+    void $ Gap.load' Nothing LoadAllTargets msg mod_graph  -- | Add a hook to record the contents of any 'TypecheckedModule's which are produced -- during compilation.@@ -194,7 +200,8 @@ -- target file to be a temporary file. guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target guessTargetMapped (orig_file_name, mapped_file_name) = do-  t <- Gap.guessTarget orig_file_name Nothing+  df <- Gap.getDynFlags+  t <- Gap.guessTarget orig_file_name (Just $ Gap.homeUnitId_ df) Nothing   return (setTargetFilename mapped_file_name t)  setTargetFilename :: FilePath -> Target -> Target

@@ -40,6 +40,11 @@ import HIE.Bios.Ghc.Api (withDynFlags) import qualified HIE.Bios.Ghc.Gap as Gap +#if __GLASGOW_HASKELL__ >= 903+import GHC.Types.Error+import GHC.Driver.Errors.Types+#endif+ ----------------------------------------------------------------  type Builder = [String] -> [String]@@ -56,7 +61,12 @@     return $! unlines (b [])  appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction-appendLogRef df style (LogRef ref) _ _ sev src+appendLogRef df style (LogRef ref)+#if __GLASGOW_HASKELL__ < 903+    _ _ sev src+#else+    _ (MCDiagnostic sev _) src+#endif #if __GLASGOW_HASKELL__ < 900   _style #endif@@ -101,10 +111,25 @@ sourceError err = do     dflag <- getSessionDynFlags     style <- getStyle dflag+#if __GLASGOW_HASKELL__ >= 903+    let ret = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err+#else     let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err+#endif     return (Left ret) -#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 903+errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String]+errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList+++ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope GhcMessage -> String+ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext+   where+     spn = errMsgSpan err+     msg = pprLocMsgEnvelope err+     -- fixme+#elif __GLASGOW_HASKELL__ >= 902 errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList 

@@ -6,30 +6,24 @@ {-# LANGUAGE TypeApplications #-} module Main where +import Utils+ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.ExpectedFailure import qualified Test.Tasty.Options as Tasty import qualified Test.Tasty.Ingredients as Tasty-import qualified GHC as G import HIE.Bios-import HIE.Bios.Ghc.Api-import HIE.Bios.Ghc.Load import HIE.Bios.Cradle-import HIE.Bios.Environment-import HIE.Bios.Types-import Control.Monad.IO.Class-import Control.Monad ( forM_, unless )-import Data.List ( sort, isPrefixOf, isInfixOf )+import Control.Monad ( forM_ )+import Data.List ( sort, isPrefixOf ) import Data.Typeable-import Data.Void import System.Directory-import System.FilePath (addTrailingPathSeparator,  makeRelative, (</>) )-import System.Info.Extra ( isWindows )-import System.IO.Temp+import System.FilePath ((</>) ) import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Control.Monad.Extra (unlessM) import qualified HIE.Bios.Ghc.Gap as Gap+import Control.Monad.IO.Class  argDynamic :: [String] argDynamic = ["-dynamic" | Gap.hostIsDynamic]@@ -55,350 +49,223 @@   defaultMainWithIngredients (ignoreToolTests:defaultIngredients) $     testGroup "Bios-tests"       [ testGroup "Find cradle"-        [ testCaseSteps "simple-cabal"-                (findCradleForModule-                  "./tests/projects/simple-cabal/B.hs"-                  (Just "./tests/projects/simple-cabal/hie.yaml")-                )+        [ testCaseSteps "simple-cabal" $+            runTestEnvLocal "./simple-cabal" $ do+              findCradleForModuleM "B.hs" (Just "hie.yaml")          -- Checks if we can find a hie.yaml even when the given filepath         -- is unknown. This functionality is required by Haskell IDE Engine.-        , testCaseSteps "simple-cabal-unknown-path"-                (findCradleForModule-                  "./tests/projects/simple-cabal/Foo.hs"-                  (Just "./tests/projects/simple-cabal/hie.yaml")-                )-        ]-      , testGroup "Symlink"-        [ testCaseSteps "Can load base module" $ \step -> do-            withTempCopy "./tests/projects/symlink-test" $ \tmpdir -> do-              crdl <- initialiseCradle isMultiCradle (addTrailingPathSeparator tmpdir) step-              step "Load module A"-              withCurrentDirectory (cradleRootDir crdl) $ do-                runCradle (cradleOptsProg crdl) mempty "./a/A.hs"-                >>= \case-                  CradleSuccess r ->-                    componentOptions r `shouldMatchList` ["a"] <> argDynamic-                  _ -> assertFailure "Cradle could not be loaded"--        , testCaseSteps "Can load symlinked module" $ \step -> do-            withTempCopy "./tests/projects/symlink-test" $ \tmpdir -> do-              crdl <- initialiseCradle isMultiCradle (addTrailingPathSeparator tmpdir) step-              step "Attemp to load symlinked module A"-              withCurrentDirectory (cradleRootDir crdl) $ do-                createDirectoryLink "./a" "./b"-                unlessM (doesFileExist "./b/A.hs")-                  $ assertFailure "Test invariant broken, this file must exist."--                runCradle (cradleOptsProg crdl) mempty "./b/A.hs"-                >>= \case-                  CradleSuccess r ->-                    componentOptions r `shouldMatchList` ["b"] <> argDynamic-                  _ -> assertFailure "Cradle could not be loaded"--        , testCaseSteps "Can not load symlinked module that is ignored" $ \step -> do-            withTempCopy "./tests/projects/symlink-test" $ \tmpdir -> do-              crdl <- initialiseCradle isMultiCradle (addTrailingPathSeparator tmpdir) step-              step "Attemp to load symlinked module A"-              withCurrentDirectory (cradleRootDir crdl) $ do-                createDirectoryLink "./a" "./c"-                unlessM (doesFileExist "./c/A.hs")-                  $ assertFailure "Test invariant broken, this file must exist."--                runCradle (cradleOptsProg crdl) mempty "./c/A.hs"-                  >>= \case-                    CradleNone -> pure ()-                    _ -> assertFailure "Cradle loaded symlink"+        , testCaseSteps "simple-cabal-unknown-path" $+            runTestEnvLocal "./simple-cabal" $ do+              findCradleForModuleM "Foo.hs" (Just "hie.yaml")         ]+      , testGroup "Symlink" symbolicLinkTests       , testGroup "Loading tests"         [ testGroup "bios" biosTestCases         , testGroup "direct" directTestCases         , testGroupWithDependency cabalDep (cabalTestCases extraGhcDep)-        , ignoreOnGhc9AndNewer $ testGroupWithDependency stackDep stackTestCases+        , ignoreOnUnsupportedGhc $ testGroupWithDependency stackDep stackTestCases         ]       ] -linuxExlusiveTestCases :: [TestTree]-linuxExlusiveTestCases-  | not isWindows-  = [ testCaseSteps "simple-bios" $ testDirectory isBiosCradle "./tests/projects/simple-bios" "B.hs"-    , testCaseSteps "simple-bios-ghc" $ testDirectory isBiosCradle "./tests/projects/simple-bios-ghc" "B.hs"-    , testCaseSteps "simple-bios-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios" "B.hs" (assertEqual "dependencies" ["hie-bios.sh", "hie.yaml"])-    , testCaseSteps "simple-bios-deps-new" $ testLoadCradleDependencies isBiosCradle "./tests/projects/deps-bios-new" "B.hs" (assertEqual "dependencies" ["hie-bios.sh", "hie.yaml"])-    ]-  | otherwise-  = []+symbolicLinkTests :: [TestTree]+symbolicLinkTests =+  [ testCaseSteps "Can load base module" $ runTestEnv "./symlink-test" $ do+      initCradle "doesNotExist.hs"+      assertCradle isMultiCradle+      step "Attempt to load symlinked module A"+      inCradleRootDir $ do+        loadComponentOptions "./a/A.hs"+        assertComponentOptions $ \opts ->+          componentOptions opts `shouldMatchList` ["a"] <> argDynamic +  , testCaseSteps "Can load symlinked module" $ runTestEnv "./symlink-test" $ do+      initCradle "doesNotExist.hs"+      assertCradle isMultiCradle+      step "Attempt to load symlinked module A"+      inCradleRootDir $ do+        liftIO $ createDirectoryLink "./a" "./b"+        liftIO $ unlessM (doesFileExist "./b/A.hs") $+          assertFailure "Test invariant broken, this file must exist."+        loadComponentOptions "./b/A.hs"+        assertComponentOptions $ \opts ->+          componentOptions opts `shouldMatchList` ["b"] <> argDynamic+  , testCaseSteps "Can not load symlinked module that is ignored" $ runTestEnv "./symlink-test" $ do+      initCradle "doesNotExist.hs"+      assertCradle isMultiCradle+      step "Attempt to load symlinked module A"+      inCradleRootDir $ do+        liftIO $ createDirectoryLink "./a" "./c"+        liftIO $ unlessM (doesFileExist "./c/A.hs") $+          assertFailure "Test invariant broken, this file must exist."+        loadComponentOptions "./c/A.hs"+        assertLoadNone+  ]++biosTestCases :: [TestTree]+biosTestCases =+  [ testCaseSteps "failing-bios" $ runTestEnv "./failing-bios" $ do+      initCradle "B.hs"+      assertCradle isBiosCradle+      loadComponentOptions "B.hs"+      assertCradleError $ \CradleError {..} -> do+        cradleErrorExitCode @?= ExitFailure 1+        cradleErrorDependencies `shouldMatchList` ["hie.yaml"]+  , testCaseSteps "failing-bios-ghc" $ runTestEnv "./failing-bios-ghc" $ do+      initCradle "B.hs"+      assertCradle isBiosCradle+      loadRuntimeGhcVersion+      ghcVersionLR <- askGhcVersionResult+      assertCradleLoadError ghcVersionLR >>= \CradleError {..} -> liftIO $ do+        cradleErrorExitCode @?= ExitSuccess+        cradleErrorDependencies `shouldMatchList` []+        length cradleErrorStderr @?= 1+        "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information"+  , testCaseSteps "simple-bios-shell" $ runTestEnv "./simple-bios-shell" $ do+      testDirectoryM isBiosCradle "B.hs"+  , testCaseSteps "simple-bios-shell-deps" $ runTestEnv "./simple-bios-shell" $ do+      biosCradleDeps "B.hs" ["hie.yaml"]+  ] <> concat [linuxTestCases | False] -- TODO(fendor), enable again+  where+    biosCradleDeps :: FilePath -> [FilePath] -> TestM ()+    biosCradleDeps fp deps = do+      initCradle fp+      assertCradle isBiosCradle+      loadComponentOptions fp+      assertComponentOptions $ \opts -> do+        deps @?= componentDependencies opts++    linuxTestCases =+      [ testCaseSteps "simple-bios" $ runTestEnv "./simple-bios" $+          testDirectoryM isBiosCradle "B.hs"+      , testCaseSteps "simple-bios-ghc" $ runTestEnv "./simple-bios-ghc" $+          testDirectoryM isBiosCradle  "B.hs"+      , testCaseSteps "simple-bios-deps" $ runTestEnv "./simple-bios" $ do+          biosCradleDeps "B.hs" ["hie-bios.sh", "hie.yaml"]+      , testCaseSteps "simple-bios-deps-new" $ runTestEnv "./deps-bios-new" $ do+          biosCradleDeps "B.hs" ["hie-bios.sh", "hie.yaml"]+      ]+ cabalTestCases :: ToolDependency -> [TestTree] cabalTestCases extraGhcDep =-  [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal" "MyLib.hs"-    (\CradleError {..} -> do+  [ testCaseSteps "failing-cabal" $ runTestEnv "./failing-cabal" $ do+      cabalAttemptLoad "MyLib.hs"+      assertCradleError (\CradleError {..} -> do         cradleErrorExitCode @?= ExitFailure 1         cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"])-  , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal" "B.hs"-  , testCaseSteps "nested-cabal" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "sub-comp/Lib.hs"-    (\deps -> deps `shouldMatchList` ["sub-comp" </> "sub-comp.cabal", "cabal.project", "cabal.project.local"]-    )-  , testCaseSteps "nested-cabal2" $ testLoadCradleDependencies isCabalCradle "./tests/projects/nested-cabal" "MyLib.hs"-    (\deps -> deps `shouldMatchList` ["nested-cabal.cabal", "cabal.project", "cabal.project.local"]-    )-  , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}-                $  testDirectory isCabalCradle "./tests/projects/multi-cabal" "app/Main.hs"-                >> testDirectory isCabalCradle "./tests/projects/multi-cabal" "src/Lib.hs"-  , testCaseSteps "monorepo-cabal" {- issue https://github.com/mpickering/hie-bios/issues/200 -}-                $  testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "A/Main.hs"-                >> testDirectory isCabalCradle "./tests/projects/monorepo-cabal" "B/MyLib.hs"+  , testCaseSteps "simple-cabal" $ runTestEnv "./simple-cabal" $ do+      testDirectoryM isCabalCradle "B.hs"+  , testCaseSteps "nested-cabal" $ runTestEnv "./nested-cabal" $ do+      cabalAttemptLoad "sub-comp/Lib.hs"+      assertComponentOptions $ \opts -> do+        componentDependencies opts `shouldMatchList`+          [ "sub-comp" </> "sub-comp.cabal"+          , "cabal.project"+          , "cabal.project.local"+          ]+  , testCaseSteps "nested-cabal2" $ runTestEnv "./nested-cabal" $ do+      cabalAttemptLoad "MyLib.hs"+      assertComponentOptions $ \opts -> do+        componentDependencies opts `shouldMatchList`+          [ "nested-cabal.cabal"+          , "cabal.project"+          , "cabal.project.local"+          ]+  , testCaseSteps "multi-cabal" $ runTestEnv "./multi-cabal" $ do+      {- tests if both components can be loaded -}+      testDirectoryM isCabalCradle "app/Main.hs"+      testDirectoryM isCabalCradle "src/Lib.hs"+  , {- issue https://github.com/mpickering/hie-bios/issues/200 -}+    testCaseSteps "monorepo-cabal" $ runTestEnv "./monorepo-cabal" $ do+      testDirectoryM isCabalCradle "A/Main.hs"+      testDirectoryM isCabalCradle "B/MyLib.hs"   , testGroup "Implicit cradle tests" $-        [ testCaseSteps "implicit-cabal" $-            testImplicitCradle "./tests/projects/implicit-cabal" "Main.hs" Cabal-        , testCaseSteps "implicit-cabal-no-project" $-            testImplicitCradle "./tests/projects/implicit-cabal-no-project" "Main.hs" Cabal-        , testCaseSteps "implicit-cabal-deep-project" $-            testImplicitCradle "./tests/projects/implicit-cabal-deep-project" "foo/Main.hs" Cabal-        ]+      [ testCaseSteps "implicit-cabal" $ runTestEnv "./implicit-cabal" $ do+          testImplicitDirectoryM isCabalCradle "Main.hs"+      , testCaseSteps "implicit-cabal-no-project" $ runTestEnv "./implicit-cabal-no-project" $ do+          testImplicitDirectoryM isCabalCradle "Main.hs"+      , testCaseSteps "implicit-cabal-deep-project" $ runTestEnv "./implicit-cabal-deep-project" $ do+          testImplicitDirectoryM isCabalCradle "foo/Main.hs"+      ]   , testGroupWithDependency extraGhcDep-    [ testCaseSteps "Appropriate ghc and libdir" $ \step -> do-        fp <- canonicalizePath "./tests/projects/cabal-with-ghc/src/MyLib.hs"-        crd <- initialiseCradle isCabalCradle fp step-        step "Get runtime GHC library directory"-        testGetGhcLibDir crd extraGhcVersion-        step "Get runtime GHC version"-        testGetGhcVersion crd extraGhcVersion+    [ testCaseSteps "Appropriate ghc and libdir" $ runTestEnvLocal "./cabal-with-ghc" $ do+        initCradle "src/MyLib.hs"+        assertCradle isCabalCradle+        loadRuntimeGhcLibDir+        assertLibDirVersionIs extraGhcVersion+        loadRuntimeGhcVersion+        assertGhcVersionIs extraGhcVersion     ]   ]+  where+    cabalAttemptLoad :: FilePath -> TestM ()+    cabalAttemptLoad fp = do+      initCradle fp+      assertCradle isCabalCradle+      loadComponentOptions fp  stackTestCases :: [TestTree] stackTestCases =   [ expectFailBecause "stack repl does not fail on an invalid cabal file" $-      testCaseSteps "failing-stack" $ testDirectoryFail isStackCradle "./tests/projects/failing-stack" "src/Lib.hs"-        (\CradleError {..} -> do+      testCaseSteps "failing-stack" $ runTestEnv "./failing-stack" $ do+        stackAttemptLoad "src/Lib.hs"+        assertCradleError $ \CradleError {..} -> do             cradleErrorExitCode @?= ExitFailure 1-            cradleErrorDependencies `shouldMatchList` ["failing-stack.cabal", "stack.yaml", "package.yaml"])-  , testCaseSteps "simple-stack" $ testDirectory isStackCradle "./tests/projects/simple-stack" "B.hs"-  , testCaseSteps "multi-stack" {- tests if both components can be loaded -}-                $  testDirectory isStackCradle "./tests/projects/multi-stack" "app/Main.hs"-                >> testDirectory isStackCradle "./tests/projects/multi-stack" "src/Lib.hs"-  , testCaseSteps "nested-stack" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "sub-comp/Lib.hs"-        (\deps -> deps `shouldMatchList`-          ["sub-comp" </> "sub-comp.cabal", "sub-comp" </> "package.yaml", "stack.yaml"]-        )-  , testCaseSteps "nested-stack2" $ testLoadCradleDependencies isStackCradle "./tests/projects/nested-stack" "MyLib.hs"-      (\deps -> deps `shouldMatchList` ["nested-stack.cabal", "package.yaml", "stack.yaml"]-      )-  , testCaseSteps "stack-with-yaml" {- tests if both components can be loaded -}-                $  testDirectory isStackCradle "./tests/projects/stack-with-yaml" "app/Main.hs"-                >> testDirectory isStackCradle "./tests/projects/stack-with-yaml" "src/Lib.hs"-  , testCaseSteps "multi-stack-with-yaml" {- tests if both components can be loaded -}-                $  testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appA/src/Lib.hs"-                >> testDirectory isStackCradle "./tests/projects/multi-stack-with-yaml" "appB/src/Lib.hs"+            cradleErrorDependencies `shouldMatchList` ["failing-stack.cabal", "stack.yaml", "package.yaml"]+  , testCaseSteps "simple-stack" $ runTestEnv "./simple-stack" $ do+      testDirectoryM isStackCradle "B.hs"+  , testCaseSteps "multi-stack" $ runTestEnv "./multi-stack" $ do {- tests if both components can be loaded -}+      testDirectoryM isStackCradle "app/Main.hs"+      testDirectoryM isStackCradle "src/Lib.hs"+  , testCaseSteps "nested-stack" $ runTestEnv "./nested-stack" $ do+      stackAttemptLoad "sub-comp/Lib.hs"+      assertComponentOptions $ \opts ->+        componentDependencies opts `shouldMatchList` ["sub-comp" </> "sub-comp.cabal", "sub-comp" </> "package.yaml", "stack.yaml"]+  , testCaseSteps "nested-stack2" $ runTestEnv "./nested-stack" $ do+      stackAttemptLoad "MyLib.hs"+      assertComponentOptions $ \opts ->+        componentDependencies opts `shouldMatchList` ["nested-stack.cabal", "package.yaml", "stack.yaml"]+  , testCaseSteps "stack-with-yaml" $ runTestEnv "./stack-with-yaml" $ do+      {- tests if both components can be loaded -}+      testDirectoryM isStackCradle "app/Main.hs"+      testDirectoryM isStackCradle "src/Lib.hs"+  , testCaseSteps "multi-stack-with-yaml" $ runTestEnv "./multi-stack-with-yaml" $ do+      {- tests if both components can be loaded -}+      testDirectoryM isStackCradle "appA/src/Lib.hs"+      testDirectoryM isStackCradle "appB/src/Lib.hs"   ,     -- Test for special characters in the path for parsing of the ghci-scripts.     -- Issue https://github.com/mpickering/hie-bios/issues/162-    testCaseSteps "space stack"-                  $  testDirectory isStackCradle "./tests/projects/space stack" "A.hs"-                  >> testDirectory isStackCradle "./tests/projects/space stack" "B.hs"+    testCaseSteps "space stack" $ runTestEnv "./space stack" $ do+      testDirectoryM isStackCradle "A.hs"+      testDirectoryM isStackCradle "B.hs"   , testGroup "Implicit cradle tests"-      [ testCaseSteps "implicit-stack" $-          testImplicitCradle "./tests/projects/implicit-stack" "Main.hs" Stack-      , testCaseSteps "implicit-stack-multi"-          $ testImplicitCradle "./tests/projects/implicit-stack-multi" "Main.hs" Stack-          >> testImplicitCradle "./tests/projects/implicit-stack-multi" "other-package/Main.hs" Stack+      [ testCaseSteps "implicit-stack" $ runTestEnv "./implicit-stack" $+          testImplicitDirectoryM isStackCradle "Main.hs"+      , testCaseSteps "implicit-stack-multi" $ runTestEnv "./implicit-stack-multi" $ do+          testImplicitDirectoryM isStackCradle "Main.hs"+          testImplicitDirectoryM isStackCradle "other-package/Main.hs"       ]   ]--biosTestCases :: [TestTree]-biosTestCases =-  [ testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios" "B.hs"-    (\CradleError {..} -> do-        cradleErrorExitCode @?= ExitFailure 1-        cradleErrorDependencies `shouldMatchList` ["hie.yaml"])-  , testCaseSteps "failing-bios-ghc" $ testGetGhcVersionFail isBiosCradle "./tests/projects/failing-bios-ghc" "B.hs"-    (\CradleError {..} -> do-        cradleErrorExitCode @?= ExitSuccess-        cradleErrorDependencies `shouldMatchList` []-        length cradleErrorStderr @?= 1-        "Couldn't execute myGhc" `isPrefixOf` head cradleErrorStderr @? "Error message should contain basic information" )-  , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell" "B.hs"-  , testCaseSteps "simple-bios-shell-deps" $ testLoadCradleDependencies isBiosCradle "./tests/projects/simple-bios-shell" "B.hs" (assertEqual "dependencies" ["hie.yaml"])-  ]+  where+    stackAttemptLoad :: FilePath -> TestM ()+    stackAttemptLoad fp = do+      initCradle fp+      assertCradle isStackCradle+      loadComponentOptions fp  directTestCases :: [TestTree] directTestCases =-  [ testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct" "B.hs"-  , testCaseSteps "multi-direct" {- tests if both components can be loaded -}-      $  testDirectory isMultiCradle "./tests/projects/multi-direct" "A.hs"-      >> testDirectory isMultiCradle "./tests/projects/multi-direct" "B.hs"+  [ testCaseSteps "simple-direct" $ runTestEnv  "./simple-direct" $ do+      testDirectoryM isDirectCradle "B.hs"+  , testCaseSteps "multi-direct" $ runTestEnv "./multi-direct" $ do+      {- tests if both components can be loaded -}+      testDirectoryM isMultiCradle "A.hs"+      testDirectoryM isMultiCradle "B.hs"   ] -testDirectory :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (String -> IO ()) -> IO ()-testDirectory cradlePred rootDir file step =-  -- 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!-  withTempCopy rootDir $ \rootDir' -> do-    fp <- canonicalizePath (rootDir' </> file)-    crd <- initialiseCradle cradlePred fp step-    step "Get runtime GHC library directory"-    testGetGhcLibDir crd VERSION_ghc-    step "Get runtime GHC version"-    testGetGhcVersion crd VERSION_ghc-    step "Initialise Flags"-    testLoadFile crd fp step---- | Here we are testing that the cradle's method of obtaining the ghcLibDir--- always works.-testGetGhcLibDir :: Cradle a -> String -> IO ()-testGetGhcLibDir crd ghcVersion = do-  libDirRes <- getRuntimeGhcLibDir crd-  isSuccess libDirRes-  where-    -- heuristically test that the produced $libdir makes sense.-    isSuccess (CradleSuccess path) =-      ghcVersion `isInfixOf` path @? "Expected \"" ++ ghcVersion-                                     ++ "\" to be infix of: " ++ path-    isSuccess _ =-      assertFailure "Must succeed loading ghc lib directory"---- | Here we are testing that the cradle's method of getting the runtime ghc--- version is correct - which while testing, should be the version that we have--- built the tests with. This will fail if you compiled the tests with a ghc--- that doesn't equal the ghc on your path though :(-testGetGhcVersion :: Cradle a -> String -> IO ()-testGetGhcVersion crd ghcVersion = do-  version <- getRuntimeGhcVersion crd-  version @?= CradleSuccess ghcVersion--testGetGhcVersionFail :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (CradleError -> Assertion) -> (String -> IO ()) -> IO ()-testGetGhcVersionFail cradlePred rootDir file cradleFailPred step =-  testCradle cradlePred rootDir file step $ \crd _ -> do-    res <- getRuntimeGhcVersion crd--    case res of-      CradleSuccess _ -> liftIO $ assertFailure "Cradle loaded successfully"-      CradleNone -> liftIO $ assertFailure "Unexpected none-Cradle"-      CradleFail crdlFail -> liftIO $ cradleFailPred crdlFail--testDirectoryFail :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (CradleError -> Assertion) -> (String -> IO ()) -> IO ()-testDirectoryFail cradlePred rootDir file cradleFailPred step =-  testCradle cradlePred rootDir file step $ \crd fp ->-    testLoadFileCradleFail crd fp cradleFailPred step--testCradle :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (String -> IO ()) -> (Cradle Void -> FilePath -> IO a) -> IO a-testCradle cradlePred rootDir file step cont = withTempCopy rootDir $ \rootDir' -> do-    fp <- canonicalizePath (rootDir' </> file)-    crd <- initialiseCradle cradlePred fp step-    step "Initialise Flags"-    cont crd fp--initialiseCradle :: (Cradle Void -> Bool) -> FilePath -> (String -> IO ()) -> IO (Cradle Void)-initialiseCradle cradlePred a_fp step = do-  step $ "Finding Cradle for: " ++ a_fp-  mcfg <- findCradle a_fp-  step $ "Loading Cradle: " ++ show mcfg-  crd <- case mcfg of-          Just cfg -> loadCradle cfg-          Nothing -> loadImplicitCradle a_fp-  cradlePred crd @? "Must be the correct kind of cradle"-  pure crd--testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO ()-testLoadFile crd a_fp step = do-  libDirRes <- getRuntimeGhcLibDir crd-  handleCradleResult libDirRes $ \libDir ->-    withCurrentDirectory (cradleRootDir crd) $-      G.runGhc (Just libDir) $ do-        let relFp = makeRelative (cradleRootDir crd) a_fp-        liftIO (step "Cradle load")-        res <- initializeFlagsWithCradle mempty relFp crd-        handleCradleResult res $ \(ini, _) -> do-          liftIO (step "Initial module load")-          sf <- ini-          case sf of-            -- Test resetting the targets-            Succeeded -> do-              liftIO (step "Set target files")-              setTargetFiles mempty [(a_fp, a_fp)]-            Failed -> liftIO $ assertFailure "Module loading failed"--testLoadFileCradleFail :: Cradle a -> FilePath -> (CradleError -> Assertion) -> (String -> IO ()) -> IO ()-testLoadFileCradleFail crd a_fp cradleErrorExpectation step = do-  step "Loading cradle"-  -- don't spin up a ghc session, just run the opts program manually since-  -- we're not guaranteed to be able to get the ghc libdir if the cradle is-  -- failing-  withCurrentDirectory (cradleRootDir crd) $ do-    let relFp = makeRelative (cradleRootDir crd) a_fp-    res <- runCradle (cradleOptsProg crd) mempty relFp-    case res of-      CradleSuccess _ -> liftIO $ assertFailure "Cradle loaded successfully"-      CradleNone -> liftIO $ assertFailure "Unexpected none-Cradle"-      CradleFail crdlFail -> liftIO $ cradleErrorExpectation crdlFail--testLoadCradleDependencies :: (Cradle Void -> Bool) -> FilePath -> FilePath -> ([FilePath] -> Assertion) -> (String -> IO ()) -> IO ()-testLoadCradleDependencies cradlePred rootDir file dependencyPred step =-  withTempCopy rootDir $ \rootDir' -> do-    a_fp <- canonicalizePath (rootDir' </> file)-    crd <- initialiseCradle cradlePred a_fp step-    libDirRes <- getRuntimeGhcLibDir crd-    handleCradleResult libDirRes $ \libDir -> do-      step "Initialise Flags"-      withCurrentDirectory (cradleRootDir crd) $-        G.runGhc (Just libDir) $ do-          let relFp = makeRelative (cradleRootDir crd) a_fp-          res <- initializeFlagsWithCradleWithMessage mempty (Just (\_ n _ _ -> step (show n))) relFp crd-          handleCradleResult res $ \(_, options) ->-            liftIO $ dependencyPred (componentDependencies options)--handleCradleResult :: MonadIO m => CradleLoadResult a -> (a -> m ()) -> m ()-handleCradleResult (CradleSuccess x) f = f x-handleCradleResult CradleNone _ = liftIO $ assertFailure "Unexpected none-Cradle"-handleCradleResult (CradleFail (CradleError _deps _ex stde)) _ =-  liftIO $ assertFailure ("Unexpected cradle fail" ++ unlines stde)--findCradleForModule :: FilePath -> Maybe FilePath -> (String -> IO ()) -> IO ()-findCradleForModule fp expected' step = do-  expected <- maybe (return Nothing) (fmap Just . canonicalizePath) expected'-  a_fp <- canonicalizePath fp-  step "Finding cradle"-  crdl <- findCradle a_fp-  crdl @?= expected--testImplicitCradle :: FilePath -> FilePath -> ActionName Void -> (String -> IO ()) -> IO ()-testImplicitCradle rootDir file expectedActionName step =-  withTempCopy rootDir $ \rootDir' -> do-    fp <- makeAbsolute (rootDir' </> file)-    step "Inferring implicit cradle"-    crd <- loadImplicitCradle fp :: IO (Cradle Void)--    actionName (cradleOptsProg crd) @?= expectedActionName--    expectedCradleRootDir <- makeAbsolute rootDir'-    cradleRootDir crd @?= expectedCradleRootDir--    step "Initialize flags"-    testLoadFile crd fp step--withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a-withTempCopy srcDir f =-  withSystemTempDirectory "hie-bios-test" $ \newDir -> do-    copyDir srcDir newDir-    f newDir--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"]- -- --------------------------------------------------------------------- Helper functions+-- Unit-test Helper functions -- ------------------------------------------------------------------  shouldMatchList :: (Show a, Ord a) => [a] -> [a] -> Assertion@@ -406,6 +273,10 @@  infix 1 `shouldMatchList` +-- ------------------------------------------------------------------+-- Stack related helper functions+-- ------------------------------------------------------------------+ writeStackYamlFiles :: IO () writeStackYamlFiles =   forM_ stackProjects $ \(proj, syaml, pkgs) ->@@ -432,8 +303,12 @@  stackYamlResolver :: String stackYamlResolver =-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)))-  "nightly-2021-08-22" -- GHC 9.0.1+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,2,1,0)))+  "nightly-2022-09-11" -- GHC 9.2.4+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)))+  "lts-19.22" -- GHC 9.0.2+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,7,0)))+  "lts-18.28" -- GHC 8.10.7 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)))   "lts-18.6" -- GHC 8.10.4 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)))@@ -496,22 +371,21 @@   optionHelp = pure "Run tests whether their tool dependencies exist or not"   optionCLParser = Tasty.flagCLParser Nothing (IgnoreToolDeps True) --- | The ingredient that provides the test listing functionality+-- | The ingredient that provides the "ignore missing run-time dependencies" functionality ignoreToolTests :: Tasty.Ingredient ignoreToolTests = Tasty.TestManager [Tasty.Option (Proxy :: Proxy IgnoreToolDeps)] $-  \opts _tree ->-    case Tasty.lookupOption opts of-      IgnoreToolDeps False -> Nothing-      IgnoreToolDeps True -> Just $ pure True+  \_opts _tree -> Nothing  -- --------------------------------------------------------------------- Ignore test group if built with GHC 9 or newer+-- Ignore test group if built with GHC 9.2.1 until GHC 9.2.4 -- ------------------------------------------------------------------ -ignoreOnGhc9AndNewer :: TestTree -> TestTree-ignoreOnGhc9AndNewer tt =-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,0,0,0))-  ignoreTestBecause "Not supported on GHC >= 9"+ignoreOnUnsupportedGhc :: TestTree -> TestTree+ignoreOnUnsupportedGhc tt =+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,4,0,0))+  ignoreTestBecause "Not supported on GHC >= 9.4"+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,2,1,0) && !MIN_VERSION_GLASGOW_HASKELL(9,2,4,0))+  ignoreTestBecause "Not supported on GHC >= 9.2.1 && < 9.2.4" #endif   tt 

@@ -0,0 +1,439 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Utils (+  -- * Test Environment+  TestM,+  TestEnv,+  TestConfig (..),+  defConfig,++  -- * Run Tests+  runTestEnv,+  runTestEnv',+  runTestEnvLocal,++  -- * Low-level test-env modification helpers+  setCradle,+  unsetCradle,+  setLoadResult,+  unsetLoadResult,+  setLibDirResult,+  setGhcVersionResult,++  -- * Ask for test environment+  askRoot,+  askStep,+  askCradle,+  askLoadResult,+  askOrLoadLibDir,+  askLibDir,+  askLibDirResult,+  askGhcVersion,+  askGhcVersionResult,++  -- * Test setup helpers+  step,+  normFile,+  relFile,+  findCradleLoc,+  initCradle,+  initImplicitCradle,+  loadComponentOptions,+  loadRuntimeGhcLibDir,+  loadRuntimeGhcVersion,+  inCradleRootDir,+  loadFileGhc,++  -- * Assertion helpers+  assertCradle,+  assertLibDirVersion,+  assertGhcVersion,+  assertLibDirVersionIs,+  assertGhcVersionIs,+  assertComponentOptions,+  assertCradleError,+  assertLoadSuccess,+  assertLoadFailure,+  assertLoadNone,+  assertCradleLoadSuccess,+  assertCradleLoadError,++  -- * High-level test helpers+  testDirectoryM,+  testImplicitDirectoryM,+  findCradleForModuleM,+) where++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.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+import System.Directory+import System.FilePath+import System.IO.Temp+import Test.Tasty.HUnit++-- ---------------------------------------------------------------------------+-- Test configuration and information+-- ---------------------------------------------------------------------------++type TestM a = StateT (TestEnv Void) IO a++data TestConfig = TestConfig+  { useTemporaryDirectory :: Bool+  , testProjectRoots :: FilePath+  }+  deriving (Eq, Show, Ord)++data TestEnv ext = TestEnv+  { testCradleType :: Maybe (Cradle ext)+  , testLoadResult :: Maybe (CradleLoadResult ComponentOptions)+  , testLibDirResult :: Maybe (CradleLoadResult FilePath)+  , testGhcVersionResult :: Maybe (CradleLoadResult String)+  , testRootDir :: FilePath+  , testStepFunction :: String -> IO ()+  }++defConfig :: TestConfig+defConfig = TestConfig True "./tests/projects"++runTestEnv :: FilePath -> TestM a -> (String -> IO ()) -> IO a+runTestEnv = runTestEnv' defConfig++runTestEnvLocal :: FilePath -> TestM a -> (String -> IO ()) -> IO a+runTestEnvLocal = runTestEnv' defConfig{useTemporaryDirectory = False}++runTestEnv' :: TestConfig -> FilePath -> TestM a -> (String -> IO ()) -> IO a+runTestEnv' config root act stepF = 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 =+        if useTemporaryDirectory config+          then withTempCopy+          else \r cont -> cont r+      mkEnv root' =+        TestEnv+          { testCradleType = Nothing+          , testLoadResult = Nothing+          , testLibDirResult = Nothing+          , testGhcVersionResult = Nothing+          , testRootDir = root'+          , testStepFunction = stepF+          }+      realRoot = testProjectRoots config </> root+  wrapper realRoot $ \root' -> flip evalStateT (mkEnv root') $ do+    step $ "Run test in: " <> root'+    act++-- ---------------------------------------------------------------------------+-- 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 = gets testStepFunction++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"++-- ---------------------------------------------------------------------------+-- Test setup helpers+-- ---------------------------------------------------------------------------++step :: String -> TestM ()+step msg = do+  s <- gets testStepFunction+  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+  crd <- case mcfg of+    Just cfg -> liftIO $ loadCradle cfg+    Nothing -> liftIO $ loadImplicitCradle a_fp+  setCradle crd++initImplicitCradle :: FilePath -> TestM ()+initImplicitCradle fp = do+  a_fp <- normFile fp+  step $ "Loading implicit Cradle for: " <> fp+  crd <- liftIO $ loadImplicitCradle a_fp+  setCradle crd++loadComponentOptions :: FilePath -> TestM ()+loadComponentOptions fp = do+  a_fp <- normFile fp+  crd <- askCradle+  step $ "Initialise flags for: " <> fp+  clr <- liftIO $ getCompilerOptions mempty a_fp 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++inCradleRootDir :: TestM a -> TestM a+inCradleRootDir act = do+  crd <- askCradle+  prev <- liftIO getCurrentDirectory+  liftIO $ setCurrentDirectory (cradleRootDir crd)+  a <- act+  liftIO $ setCurrentDirectory prev+  pure a++loadFileGhc :: FilePath -> TestM ()+loadFileGhc fp = do+  libdir <- askOrLoadLibDir+  a_fp <- normFile fp+  stepF <- askStep+  step "Cradle load"+  loadComponentOptions fp+  opts <- assertLoadSuccess+  liftIO $+    G.runGhc (Just libdir) $ do+      let (ini, _) = initSessionWithMessage (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"++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)) ->+    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 = do+  initImplicitCradle file+  assertCradle cradlePred+  loadRuntimeGhcLibDir+  assertLibDirVersion+  loadRuntimeGhcVersion+  assertGhcVersion+  loadFileGhc file++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 :: FilePath -> (FilePath -> IO a) -> IO a+withTempCopy srcDir f =+  withSystemTempDirectory "hie-bios-test" $ \newDir -> do+    copyDir srcDir newDir+    f newDir++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"]