Store dependencies in CradleError

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

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,

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

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
+      return $ show crdl

src/HIE/Bios/Types.hs

@@ -73,16 +73,26 @@ 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
 ----------------------------------------------------------------
 
 -- | 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.

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"

tests/projects/failing-bios/A.hs

@@ -0,0 +1 @@
+module A where

tests/projects/failing-bios/B.hs

@@ -0,0 +1,3 @@
+module B where
+
+import A

tests/projects/failing-bios/hie.yaml

@@ -0,0 +1,5 @@
+cradle:
+  bios:
+    shell: "exit 1"
+dependencies:
+- hie.yaml

tests/projects/failing-cabal/MyLib.hs

@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

tests/projects/failing-cabal/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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

tests/projects/failing-cabal/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

tests/projects/failing-stack/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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

tests/projects/failing-stack/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  stack:

tests/projects/failing-stack/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"