Make runGhcCmd return CradleLoadResult

This way we can include better error messages when it fails

src/HIE/Bios/Cradle.hs

@@ -229,7 +229,7 @@ noneCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.None
         , runCradle = \_ _ -> return CradleNone
-        , runGhcCmd = const $ pure Nothing
+        , runGhcCmd = \_   -> return CradleNone
         }
     }
 
@@ -248,7 +248,7 @@ multiCradle buildCustomCradle cur_dir cs =
             -- first non-none cradle. This shouldn't matter in practice: all
             -- sub cradles should be using the same ghc version!
             case filter (not . isNoneCradleConfig) $ map snd cs of
-              [] -> return Nothing
+              [] -> return CradleNone
               (cfg:_) -> flip runGhcCmd args $ cradleOptsProg $
                 getCradle buildCustomCradle (cfg, cur_dir)
         }
@@ -392,7 +392,7 @@ cabalCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Cabal
         , runCradle = cabalAction wdir mc
-        , runGhcCmd = \args -> optional $ do
+        , runGhcCmd = \args -> do
             -- Workaround for a cabal-install bug on 3.0.0.0:
             -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
             -- (It's ok to pass 'dist-newstyle' here, as it can only be changed
@@ -558,7 +558,7 @@ stackCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Stack
         , runCradle = stackAction wdir mc
-        , runGhcCmd = \args -> optional $
+        , runGhcCmd = \args ->
             readProcessWithCwd
               wdir "stack" (["exec", "--silent", "ghc", "--"] <> args) ""
         }
@@ -787,9 +787,19 @@ makeCradleResult (ex, err, componentDir, gopts) deps =
         in CradleSuccess compOpts
 
 -- | Calls @ghc --print-libdir@, with just whatever's on the PATH.
-runGhcCmdOnPath :: FilePath -> [String] -> IO (Maybe String)
-runGhcCmdOnPath wdir args = optional $ readProcessWithCwd wdir "ghc" args ""
+runGhcCmdOnPath :: FilePath -> [String] -> IO (CradleLoadResult String)
+runGhcCmdOnPath wdir args = readProcessWithCwd wdir "ghc" args ""
+  -- case mResult of
+  --   Nothing
 
 -- | Wrapper around 'readCreateProcess' that sets the working directory
-readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO String
-readProcessWithCwd dir cmd args = readCreateProcess (proc cmd args) { cwd = Just dir }
+readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String)
+readProcessWithCwd dir cmd args stdi = do
+  let createProc = (proc cmd args) { cwd = Just dir }
+  mResult <- optional $ readCreateProcessWithExitCode createProc stdi
+  case mResult of
+    Just (ExitSuccess, stdo, _) -> pure $ CradleSuccess stdo
+    Just (exitCode, stdo, stde) -> pure $ CradleFail $
+      CradleError [] exitCode ["Error when calling " <> cmd <> " " <> unwords args, stdo, stde]
+    Nothing -> pure $ CradleFail $
+      CradleError [] ExitSuccess ["Couldn't execute " <> cmd <> " " <> unwords args]

src/HIE/Bios/Environment.hs

@@ -10,7 +10,6 @@ import DynFlags
 
 import Control.Applicative
 import Control.Monad (void)
-import Control.Monad.Trans.Maybe
 
 import System.Directory
 import System.FilePath
@@ -21,7 +20,6 @@ import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Base16
 import Data.List
 import Data.Char (isSpace)
-import Data.Maybe
 import Text.ParserCombinators.ReadP hiding (optional)
 import HIE.Bios.Types
 import HIE.Bios.Ghc.Gap
@@ -74,21 +72,21 @@ makeTargetIdAbsolute _ tid = tid
 -- 1. the @NIX_GHC_LIBDIR@ if it is set
 -- 2. calling 'runCradleGhc' on the provided cradle
 getRuntimeGhcLibDir :: Cradle a
-                    -> IO (Maybe FilePath)
-getRuntimeGhcLibDir cradle = runMaybeT $ fromNix <|> fromCradle
-  where
-    fromNix = MaybeT $ lookupEnv "NIX_GHC_LIBDIR"
-    fromCradle = MaybeT $ fmap (fmap trim) $
+                    -> IO (CradleLoadResult FilePath)
+getRuntimeGhcLibDir cradle = do
+  maybeNixLibDir <- lookupEnv "NIX_GHC_LIBDIR"
+  case maybeNixLibDir of 
+    Just ld -> pure (CradleSuccess ld)
+    Nothing -> fmap (fmap trim) $
       runGhcCmd (cradleOptsProg cradle) ["--print-libdir"]
 
 -- | Gets the version of ghc used when compiling the cradle. It is based off of
 -- 'getRuntimeGhcLibDir'. If it can't work out the verison reliably, it will
 -- fall back to the version of ghc used to compile hie-bios.
 getRuntimeGhcVersion :: Cradle a
-                     -> IO String
+                     -> IO (CradleLoadResult String)
 getRuntimeGhcVersion cradle =
-  fmap (fromMaybe VERSION_ghc) $ fmap (fmap trim) $
-    runGhcCmd (cradleOptsProg cradle) ["--numeric-version"]
+  fmap (fmap trim) $ runGhcCmd (cradleOptsProg cradle) ["--numeric-version"]
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Ghc/Check.hs

@@ -30,24 +30,18 @@ checkSyntax :: Show a
             -> IO String
 checkSyntax _      []    = return ""
 checkSyntax cradle files = do
-    libDir <- getRuntimeGhcLibDir cradle
-    G.runGhcT libDir $ do
-      Log.debugm $ "Cradle: " ++ show cradle
-      res <- initializeFlagsWithCradle (head files) cradle
-      case res of
-        CradleSuccess (ini, _) -> do
+    libDirRes <- getRuntimeGhcLibDir cradle
+    handleRes libDirRes $ \libDir ->
+      G.runGhcT (Just libDir) $ do
+        Log.debugm $ "Cradle: " ++ show cradle
+        res <- initializeFlagsWithCradle (head files) cradle
+        handleRes res $ \(ini, _) -> do
           _sf <- ini
           either id id <$> check files
-        CradleFail ce -> liftIO $ throwIO ce
-        CradleNone -> return "No cradle"
-
-
   where
-    {-
-    sessionName = case files of
-      [file] -> file
-      _      -> "MultipleFiles"
-      -}
+    handleRes (CradleSuccess x) f = f x
+    handleRes (CradleFail ce) _f = liftIO $ throwIO ce 
+    handleRes CradleNone _f = return "No cradle"
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Types.hs

@@ -57,7 +57,7 @@ data CradleAction a = CradleAction {
                       -- ^ Name of the action.
                       , runCradle     :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
                       -- ^ Options to compile the given file with.
-                      , runGhcCmd :: [String] -> IO (Maybe String)
+                      , runGhcCmd :: [String] -> IO (CradleLoadResult String)
                       -- ^ Executes the @ghc@ binary that is usually used to
                       -- build the cradle. E.g. for a cabal cradle this should be
                       -- equivalent to @cabal exec ghc -- args@
@@ -74,7 +74,7 @@ data CradleLoadResult r
   = CradleSuccess r -- ^ The cradle succeeded and returned these options.
   | CradleFail CradleError -- ^ We tried to load the cradle and it failed.
   | CradleNone -- ^ No attempt was made to load the cradle.
-  deriving (Functor, Show)
+  deriving (Functor, Show, Eq)
 
 
 data CradleError = CradleError

tests/BiosTests.hs

@@ -143,16 +143,19 @@ testDirectory cradlePred rootDir file step =
 -- | Here we are testing that the cradle's method of obtaining the ghcLibDir
 -- always works.
 testGetGhcLibDir :: Cradle a -> IO ()
-testGetGhcLibDir crd =
-  getRuntimeGhcLibDir crd `shouldNotReturn` Nothing
+testGetGhcLibDir crd = do
+  libDirRes <- getRuntimeGhcLibDir crd
+  libDirRes `shouldSatisfy` isSuccess
+  where isSuccess (CradleSuccess _) = True
+        isSuccess _ = False
 
 -- | 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 -> IO ()
 testGetGhcVersion crd =
-  getRuntimeGhcVersion crd `shouldReturn` VERSION_ghc
+  getRuntimeGhcVersion crd `shouldReturn` CradleSuccess VERSION_ghc
 
 testDirectoryFail :: (Cradle Void -> Bool) -> FilePath -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO ()
 testDirectoryFail cradlePred rootDir file cradleFailPred step = do
@@ -175,21 +178,19 @@ initialiseCradle cradlePred a_fp step = do
 
 testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO ()
 testLoadFile crd a_fp step = do
-  libDir <- getRuntimeGhcLibDir crd
-  withCurrentDirectory (cradleRootDir crd) $
-    G.runGhc libDir $ do
-      let relFp = makeRelative (cradleRootDir crd) a_fp
-      res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd
-      case res of
-        CradleSuccess (ini, _) -> do
+  libDirRes <- getRuntimeGhcLibDir crd
+  handleCradleResult libDirRes $ \libDir ->
+    withCurrentDirectory (cradleRootDir crd) $
+      G.runGhc (Just libDir) $ do
+        let relFp = makeRelative (cradleRootDir crd) a_fp
+        res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd
+        handleCradleResult res $ \(ini, _) -> do
           liftIO (step "Initial module load")
           sf <- ini
           case sf of
             -- Test resetting the targets
             Succeeded -> setTargetFilesWithMessage (Just (\_ n _ _ -> step (show n))) [(a_fp, a_fp)]
             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 a_fp cradleErrorExpectation step = do
@@ -209,16 +210,21 @@ testLoadCradleDependencies cradlePred rootDir file dependencyPred step =
   withTempCopy rootDir $ \rootDir' -> do
     a_fp <- canonicalizePath (rootDir' </> file)
     crd <- initialiseCradle cradlePred a_fp step
-    libDir <- getRuntimeGhcLibDir crd
-    step "Initialise Flags"
-    withCurrentDirectory (cradleRootDir crd) $
-      G.runGhc libDir $ do
-        let relFp = makeRelative (cradleRootDir crd) a_fp
-        res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd
-        case res of
-          CradleSuccess (_, options) -> liftIO $ dependencyPred (componentDependencies options)
-          CradleNone -> liftIO $ expectationFailure "Unexpected none-Cradle"
-          CradleFail (CradleError _deps _ex stde) -> liftIO $ expectationFailure ("Unexpected cradle fail" ++ unlines stde)
+    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 (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 $ expectationFailure "Unexpected none-Cradle"
+handleCradleResult (CradleFail (CradleError _deps _ex stde)) _ =
+  liftIO $ expectationFailure ("Unexpected cradle fail" ++ unlines stde)
 
 findCradleForModule :: FilePath -> Maybe FilePath -> (String -> IO ()) -> IO ()
 findCradleForModule fp expected' step = do