diff --git a/exe/Main.hs b/exe/Main.hs index 23add7c4d..35f680710 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -80,7 +80,7 @@ main = flip E.catches handlers $ do res <- forM remainingArgs $ \fp -> do res <- getCompilerOptions fp cradle case res of - CradleFail (CradleError _ex err) -> + CradleFail (CradleError _deps _ex err) -> return $ "Failed to show flags for \"" ++ fp ++ "\": " ++ show err diff --git a/hie-bios.cabal b/hie-bios.cabal index c4f0efa51..70c35511b 100644 --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -52,6 +52,17 @@ Extra-Source-Files: ChangeLog tests/projects/multi-stack/hie.yaml tests/projects/multi-stack/multi-stack.cabal tests/projects/multi-stack/src/Lib.hs + tests/projects/failing-bios/A.hs + tests/projects/failing-bios/B.cabal + tests/projects/failing-bios/hie.yaml + tests/projects/failing-cabal/failing-cabal.cabal + tests/projects/failing-cabal/hie.yaml + tests/projects/failing-cabal/MyLib.hs + tests/projects/failing-cabal/Setup.hs + tests/projects/failing-stack/failing-stack.cabal + tests/projects/failing-stack/hie.yaml + tests/projects/failing-stack/src/Lib.hs + tests/projects/failing-stack/Setup.hs tests/projects/simple-bios/A.hs tests/projects/simple-bios/B.hs tests/projects/simple-bios/hie-bios.sh @@ -183,6 +194,8 @@ test-suite bios-tests extra, tasty, tasty-hunit, + tasty-expected-failure, + hspec-expectations, hie-bios, filepath, directory, diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index 3e64d2b2c..c248c605d 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} @@ -118,8 +119,16 @@ addCradleDeps deps c = addActionDeps :: CradleAction a -> CradleAction a addActionDeps ca = ca { runCradle = \l fp -> - (fmap (\(ComponentOptions os' dir ds) -> ComponentOptions os' dir (ds `union` deps))) - <$> runCradle ca l fp } + runCradle ca l fp + >>= \case + CradleSuccess (ComponentOptions os' dir ds) -> + pure $ CradleSuccess (ComponentOptions os' dir (ds `union` deps)) + CradleFail err -> + pure $ CradleFail + (err { cradleErrorDependencies = cradleErrorDependencies err `union` deps }) + CradleNone -> pure CradleNone + } + implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath) implicitConfig fp = do @@ -283,7 +292,7 @@ multiAction buildCustomCradle cur_dir cs l cur_fp = <$> mapM (\(p, c) -> (,c) <$> (canonicalizePath (cur_dir p))) cs selectCradle [] = - return (CradleFail (CradleError ExitSuccess err_msg)) + return (CradleFail (CradleError [] ExitSuccess err_msg)) selectCradle ((p, c): css) = if p `isPrefixOf` cur_fp then runCradle @@ -441,7 +450,7 @@ cabalAction work_dir mc l fp = do readProcessWithOutputFile l work_dir (proc "cabal" cab_args) deps <- cabalCradleDependencies work_dir case processCabalWrapperArgs args of - Nothing -> pure $ CradleFail (CradleError ex + Nothing -> pure $ CradleFail (CradleError deps ex ["Failed to parse result of calling cabal" , unlines output , unlines stde @@ -510,7 +519,7 @@ stackAction work_dir mc l _fp = do pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs deps <- stackCradleDependencies work_dir return $ case processCabalWrapperArgs args of - Nothing -> CradleFail (CradleError ex1 $ + Nothing -> CradleFail (CradleError deps ex1 $ ("Failed to parse result of calling stack": stde) ++ args) @@ -684,7 +693,7 @@ readProcessWithOutputFile l work_dir cp = do makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions makeCradleResult (ex, err, componentDir, gopts) deps = case ex of - ExitFailure _ -> CradleFail (CradleError ex err) + ExitFailure _ -> CradleFail (CradleError deps ex err) _ -> let compOpts = ComponentOptions gopts componentDir deps in CradleSuccess compOpts diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 3b95f8f6d..1bc114d65 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -46,8 +46,9 @@ debugInfo fp cradle = unlines <$> do , "Cradle: " ++ crdl , "Dependencies: " ++ unwords deps ] - CradleFail (CradleError ext stderr) -> + CradleFail (CradleError deps ext stderr) -> return ["Cradle failed to load" + , "Deps: " ++ show deps , "Exit Code: " ++ show ext , "Stderr: " ++ unlines stderr] CradleNone -> @@ -96,4 +97,4 @@ findCradle' fp = return $ show crdl Nothing -> do crdl <- loadImplicitCradle fp :: IO (Cradle Void) - return $ show crdl \ No newline at end of file + return $ show crdl diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index 584d3dc55..8f699f1f9 100644 --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -73,7 +73,17 @@ data CradleLoadResult r deriving (Functor, Show) -data CradleError = CradleError ExitCode [String] deriving (Show) +data CradleError = CradleError + { cradleErrorDependencies :: [FilePath] + -- ^ Dependencies of the cradle that failed to load. + -- Can be watched for changes to attempt a reload of the cradle. + , cradleErrorExitCode :: ExitCode + -- ^ ExitCode of the cradle loading mechanism. + , cradleErrorStderr :: [String] + -- ^ Standard error output that can be shown to users to explain + -- the loading error. + } + deriving (Show, Eq) instance Exception CradleError where ---------------------------------------------------------------- @@ -81,8 +91,8 @@ instance Exception CradleError where -- | Option information for GHC data ComponentOptions = ComponentOptions { componentOptions :: [String] -- ^ Command line options. - , componentRoot :: FilePath - -- ^ Root directory of the component. All 'componentOptions' are either + , componentRoot :: FilePath + -- ^ Root directory of the component. All 'componentOptions' are either -- absolute, or relative to this directory. , componentDependencies :: [FilePath] -- ^ Dependencies of a cradle that might change the cradle. diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index 1eac65b6d..f31505767 100644 --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -1,20 +1,24 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Main where import Test.Tasty +import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit +import Test.Hspec.Expectations import HIE.Bios import HIE.Bios.Ghc.Api import HIE.Bios.Ghc.Load import HIE.Bios.Cradle import HIE.Bios.Types import Control.Monad.IO.Class -import Control.Monad ( unless, forM_, when ) +import Control.Monad ( forM_ ) import Data.Void import System.Directory import System.FilePath ( makeRelative, () ) import System.Info.Extra ( isWindows ) +import System.Exit (ExitCode(ExitFailure)) main :: IO () main = do @@ -39,7 +43,15 @@ main = do , testGroup "Loading tests" $ linuxExlusiveTestCases ++ - [ testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell/B.hs" + [ testCaseSteps "failing-cabal" $ testDirectoryFail isCabalCradle "./tests/projects/failing-cabal/MyLib.hs" + (\CradleError {..} -> do + cradleErrorExitCode `shouldBe` ExitFailure 1 + cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"]) + , testCaseSteps "failing-bios" $ testDirectoryFail isBiosCradle "./tests/projects/failing-bios/B.hs" + (\CradleError {..} -> do + cradleErrorExitCode `shouldBe` ExitFailure 1 + cradleErrorDependencies `shouldMatchList` ["hie.yaml"]) + , testCaseSteps "simple-bios-shell" $ testDirectory isBiosCradle "./tests/projects/simple-bios-shell/B.hs" , testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal/B.hs" , testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct/B.hs" , testCaseSteps "multi-direct" {- tests if both components can be loaded -} @@ -51,7 +63,12 @@ main = do ] -- TODO: Remove once there's a stackage snapshot for ghc 8.10 #if __GLASGOW_HASKELL__ < 810 - ++ [ testCaseSteps "simple-stack" $ testDirectory isStackCradle "./tests/projects/simple-stack/B.hs" + ++ [ 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 + cradleErrorExitCode `shouldBe` 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" @@ -76,20 +93,33 @@ main = do ] linuxExlusiveTestCases :: [TestTree] -linuxExlusiveTestCases = [ testCaseSteps "simple-bios" $ testDirectory isBiosCradle "./tests/projects/simple-bios/B.hs" | not isWindows ] +linuxExlusiveTestCases = + [ testCaseSteps "simple-bios" $ testDirectory isBiosCradle "./tests/projects/simple-bios/B.hs" | not isWindows ] testDirectory :: (Cradle Void -> Bool) -> FilePath -> (String -> IO ()) -> IO () testDirectory cradlePred fp step = do a_fp <- canonicalizePath fp + crd <- initialiseCradle cradlePred a_fp step + step "Initialise Flags" + testLoadFile crd a_fp step + +testDirectoryFail :: (Cradle Void -> Bool) -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO () +testDirectoryFail cradlePred fp cradleFailPred step = do + a_fp <- canonicalizePath fp + crd <- initialiseCradle cradlePred a_fp step + step "Initialise Flags" + testLoadFileCradleFail crd a_fp cradleFailPred step + +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 - when (not $ cradlePred crd) $ error $ "Cradle is incorrect: " ++ show (actionName $ cradleOptsProg crd) - step "Initialise Flags" - testLoadFile crd a_fp step + crd `shouldSatisfy` cradlePred + pure crd testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO () testLoadFile crd fp step = do @@ -105,31 +135,35 @@ testLoadFile crd fp step = do case sf of -- Test resetting the targets Succeeded -> setTargetFilesWithMessage (Just (\_ n _ _ -> step (show n))) [(a_fp, a_fp)] - Failed -> error "Module loading failed" - CradleNone -> error "None" - CradleFail (CradleError _ex stde) -> error (unlines stde) + Failed -> liftIO $ expectationFailure "Module loading failed" + CradleNone -> liftIO $ expectationFailure "None" + CradleFail (CradleError _deps _ex stde) -> liftIO $ expectationFailure (unlines stde) + +testLoadFileCradleFail :: Cradle a -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO () +testLoadFileCradleFail crd fp cradleErrorExpectation step = do + a_fp <- canonicalizePath fp + withCurrentDirectory (cradleRootDir crd) $ + withGHC' $ do + let relFp = makeRelative (cradleRootDir crd) a_fp + res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd + case res of + CradleSuccess _ -> liftIO $ expectationFailure "Cradle loaded successfully" + CradleNone -> liftIO $ expectationFailure "Unexpected none-Cradle" + CradleFail crdlFail -> liftIO $ cradleErrorExpectation crdlFail 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" - mcfg <- findCradle a_fp - unless (mcfg == expected) - $ error - $ "Expected cradle: " - ++ show expected - ++ ", Actual: " - ++ show mcfg + findCradle a_fp `shouldReturn` expected testImplicitCradle :: FilePath -> ActionName Void -> (String -> IO ()) -> IO () testImplicitCradle fp' expectedActionName step = do fp <- canonicalizePath fp' step "Inferring implicit cradle" crd <- loadImplicitCradle fp :: IO (Cradle Void) - unless (actionName (cradleOptsProg crd) == expectedActionName) - $ error $ "Expected cradle: " <> show expectedActionName - <> "\n, Actual: " <> show (actionName (cradleOptsProg crd)) + actionName (cradleOptsProg crd) `shouldBe` expectedActionName step "Initialize flags" testLoadFile crd fp step @@ -142,6 +176,7 @@ writeStackYamlFiles = do stackProjects :: [FilePath] stackProjects = [ "tests" "projects" "multi-stack" + , "tests" "projects" "failing-stack" , "tests" "projects" "simple-stack" , "tests" "projects" "space stack" , "tests" "projects" "implicit-stack" diff --git a/tests/projects/failing-bios/A.hs b/tests/projects/failing-bios/A.hs new file mode 100644 index 000000000..e151a07b4 --- /dev/null +++ b/tests/projects/failing-bios/A.hs @@ -0,0 +1 @@ +module A where \ No newline at end of file diff --git a/tests/projects/failing-bios/B.hs b/tests/projects/failing-bios/B.hs new file mode 100644 index 000000000..ce9e7e493 --- /dev/null +++ b/tests/projects/failing-bios/B.hs @@ -0,0 +1,3 @@ +module B where + +import A diff --git a/tests/projects/failing-bios/hie.yaml b/tests/projects/failing-bios/hie.yaml new file mode 100644 index 000000000..05215de2c --- /dev/null +++ b/tests/projects/failing-bios/hie.yaml @@ -0,0 +1,5 @@ +cradle: + bios: + shell: "exit 1" +dependencies: +- hie.yaml diff --git a/tests/projects/failing-cabal/MyLib.hs b/tests/projects/failing-cabal/MyLib.hs new file mode 100644 index 000000000..e657c4403 --- /dev/null +++ b/tests/projects/failing-cabal/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/tests/projects/failing-cabal/Setup.hs b/tests/projects/failing-cabal/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/tests/projects/failing-cabal/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/projects/failing-cabal/failing-cabal.cabal b/tests/projects/failing-cabal/failing-cabal.cabal new file mode 100644 index 000000000..4769355a1 --- /dev/null +++ b/tests/projects/failing-cabal/failing-cabal.cabal @@ -0,0 +1,13 @@ +cabal-version: >=1.10 +name: failing-cabal +version: 0.1.0.0 +license-file: LICENSE +author: fendor +build-type: Simple + +library + exposed-modules: MyLib + build-depends: base >=4.13 && <4.14, + containers < 1 && > 1 + -- ^^^^^^^^^^ <<< Invalid constraint + default-language: Haskell2010 diff --git a/tests/projects/failing-cabal/hie.yaml b/tests/projects/failing-cabal/hie.yaml new file mode 100644 index 000000000..04cd24395 --- /dev/null +++ b/tests/projects/failing-cabal/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/tests/projects/failing-stack/Setup.hs b/tests/projects/failing-stack/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/tests/projects/failing-stack/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/projects/failing-stack/failing-stack.cabal b/tests/projects/failing-stack/failing-stack.cabal new file mode 100644 index 000000000..3ac32dfc8 --- /dev/null +++ b/tests/projects/failing-stack/failing-stack.cabal @@ -0,0 +1,16 @@ +cabal-version: 1.12 +name: failing-stack +version: 0.1.0.0 +description: None +build-type: Simple + +library + exposed-modules: + Lib + hs-source-dirs: + src + build-depends: + base >=4.7 && <5, + containes < 1 && > 1 + -- ^^^^^^^^^^ <<< Invalid constraint + default-language: Haskell2010 diff --git a/tests/projects/failing-stack/hie.yaml b/tests/projects/failing-stack/hie.yaml new file mode 100644 index 000000000..4ef275e05 --- /dev/null +++ b/tests/projects/failing-stack/hie.yaml @@ -0,0 +1,2 @@ +cradle: + stack: diff --git a/tests/projects/failing-stack/src/Lib.hs b/tests/projects/failing-stack/src/Lib.hs new file mode 100644 index 000000000..d36ff2714 --- /dev/null +++ b/tests/projects/failing-stack/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc"