Abstract out runGhcLibDir into runGhc

Now we can just call `cabal exec ghc -- --numeric-version` directly
without the need for guessing where the ghc binary lies.

src/HIE/Bios/Cradle.hs

@@ -40,9 +40,7 @@ import System.Environment
 import Control.Applicative ((<|>), optional)
 import System.IO.Temp
 import System.IO.Error (isPermissionError)
-import Data.Char
 import Data.List
-import Data.Foldable
 import Data.Ord (Down(..))
 
 import System.PosixCompat.Files
@@ -217,7 +215,7 @@ defaultCradle cur_dir =
         { actionName = Types.Default
         , runCradle = \_ _ ->
             return (CradleSuccess (ComponentOptions [] cur_dir []))
-        , runGhcLibDir = getGhcOnPathLibDir cur_dir
+        , runGhc = runGhcOnPath cur_dir
         }
     }
 
@@ -231,7 +229,7 @@ noneCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.None
         , runCradle = \_ _ -> return CradleNone
-        , runGhcLibDir = pure Nothing
+        , runGhc = const $ pure Nothing
         }
     }
 
@@ -245,13 +243,13 @@ multiCradle buildCustomCradle cur_dir cs =
     , cradleOptsProg = CradleAction
         { actionName = multiActionName
         , runCradle  = \l fp -> canonicalizePath fp >>= multiAction buildCustomCradle cur_dir cs l
-        , runGhcLibDir =
+        , runGhc = \args ->
             -- We're being lazy here and just returning the ghc path for the
             -- 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
-              (cfg:_) -> runGhcLibDir $ cradleOptsProg $
+              (cfg:_) -> flip runGhc args $ cradleOptsProg $
                 getCradle buildCustomCradle (cfg, cur_dir)
         }
     }
@@ -326,7 +324,7 @@ directCradle wdir args =
         { actionName = Types.Direct
         , runCradle = \_ _ ->
             return (CradleSuccess (ComponentOptions args wdir []))
-        , runGhcLibDir = getGhcOnPathLibDir wdir
+        , runGhc = runGhcOnPath wdir
         }
     }
 
@@ -342,7 +340,7 @@ biosCradle wdir biosCall biosDepsCall =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Bios
         , runCradle = biosAction wdir biosCall biosDepsCall
-        , runGhcLibDir = getGhcOnPathLibDir wdir
+        , runGhc = runGhcOnPath wdir
         }
     }
 
@@ -395,15 +393,16 @@ cabalCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Cabal
         , runCradle = cabalAction wdir mc
-        , runGhcLibDir = optional $ fmap trim $ do
+        , runGhc = \args -> optional $ 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
             -- with the --builddir flag and not cabal.project, which we aren't
             -- using in our call to v2-exec)
             createDirectoryIfMissing True (wdir </> "dist-newstyle" </> "tmp")
             -- Need to pass -v0 otherwise we get "resolving dependencies..."
-            readProcessWithCwd wdir "cabal" ["v2-exec", "ghc", "-v0", "--", "--print-libdir"] ""
+            readProcessWithCwd
+              wdir "cabal" (["v2-exec", "ghc", "-v0", "--"] ++ args) ""
         }
     }
 
@@ -521,8 +520,9 @@ stackCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Stack
         , runCradle = stackAction wdir mc
-        , runGhcLibDir = optional $ fmap trim $
-            readProcessWithCwd wdir "stack" ["exec", "--silent", "ghc", "--", "--print-libdir"] ""
+        , runGhc = \args -> optional $
+            readProcessWithCwd
+              wdir "stack" (["exec", "--silent", "ghc", "--"] <> args) ""
         }
     }
 
@@ -726,14 +726,9 @@ makeCradleResult (ex, err, componentDir, gopts) deps =
         let compOpts = ComponentOptions gopts componentDir deps
         in CradleSuccess compOpts
 
--- Used for clipping the trailing newlines on some commands
-trim :: String -> String
-trim = dropWhileEnd isSpace
-
 -- | Calls @ghc --print-libdir@, with just whatever's on the PATH.
-getGhcOnPathLibDir :: FilePath -> IO (Maybe FilePath)
-getGhcOnPathLibDir wdir = optional $
-  fmap trim $ readProcessWithCwd wdir "ghc" ["--print-libdir"] ""
+runGhcOnPath :: FilePath -> [String] -> IO (Maybe String)
+runGhcOnPath wdir args = optional $ readProcessWithCwd wdir "ghc" args ""
 
 -- | Wrapper around 'readCreateProcess' that sets the working directory
 readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO String

src/HIE/Bios/Environment.hs

@@ -10,13 +10,12 @@ import DynFlags
 import qualified GHC.Paths as Paths
 
 import Control.Applicative
-import Control.Monad (msum, void)
+import Control.Monad (void)
 import Control.Monad.Trans.Maybe
 
 import System.Directory
 import System.FilePath
 import System.Environment (lookupEnv)
-import System.Process
 
 import qualified Crypto.Hash.SHA1 as H
 import qualified Data.ByteString.Char8 as B
@@ -78,7 +77,8 @@ getRuntimeGhcLibDir cradle avoidHardcoding =
   runMaybeT $ fromNix <|> fromCradle <|> fromGhcPaths
   where
     fromNix = MaybeT $ lookupEnv "NIX_GHC_LIBDIR"
-    fromCradle = MaybeT $ runGhcLibDir $ cradleOptsProg cradle
+    fromCradle = MaybeT $ fmap (fmap trim) $
+      runGhc (cradleOptsProg cradle) ["--print-libdir"]
     fromGhcPaths = MaybeT $ pure $
       if avoidHardcoding then Just Paths.libdir else Nothing
 
@@ -87,20 +87,9 @@ getRuntimeGhcLibDir cradle avoidHardcoding =
 -- fall back to the version of ghc used to compile hie-bios.
 getRuntimeGhcVersion :: Cradle a
                      -> IO String
-getRuntimeGhcVersion cradle = fmap (fromMaybe VERSION_ghc) $ runMaybeT $ do
-  libDir <- MaybeT $ getRuntimeGhcLibDir cradle True
-  let possibleExes = guessExecutablePathFromLibdir libDir
-  MaybeT $ msum (fmap getGhcVersion possibleExes)
-  where
-    getGhcVersion :: FilePath -> IO (Maybe String)
-    getGhcVersion ghc = (Just <$> readProcess ghc ["--numeric-version"] "")
-                    <|> (pure Nothing)
-    -- Taken from ghc-check GHC.Check.Executable
-    guessExecutablePathFromLibdir :: FilePath -> [FilePath]
-    guessExecutablePathFromLibdir fp =
-        [ fp </> "bin" </> "ghc"               -- Linux
-        , fp </> ".." </> "bin" </> "ghc.exe"  -- Windows
-        ]
+getRuntimeGhcVersion cradle =
+  fmap (fromMaybe VERSION_ghc) $ fmap (fmap trim) $
+    runGhc (cradleOptsProg cradle) ["--numeric-version"]
 
 ----------------------------------------------------------------
 
@@ -325,3 +314,7 @@ value = many1 (satisfy (not . isSpace))
 
 anyToken :: ReadP Char
 anyToken = satisfy $ const True
+
+-- Used for clipping the trailing newlines on GHC output
+trim :: String -> String
+trim = dropWhileEnd isSpace

src/HIE/Bios/Ghc/Check.hs

@@ -19,7 +19,6 @@ import qualified HIE.Bios.Ghc.Gap as Gap
 
 import qualified DynFlags as G
 import qualified GHC as G
-import HIE.Bios.Environment
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Internal/Debug.hs

@@ -33,13 +33,15 @@ debugInfo fp cradle = unlines <$> do
     conf <- findConfig canonFp
     crdl <- findCradle' canonFp
     ghcLibDir <- getRuntimeGhcLibDir cradle False
+    ghcVer <- getRuntimeGhcVersion cradle
     case res of
       CradleSuccess (ComponentOptions gopts croot deps) -> do
         return [
             "Root directory:        " ++ rootDir
           , "Component directory:   " ++ croot
           , "GHC options:           " ++ unwords (map quoteIfNeeded gopts)
           , "GHC library directory: " ++ show ghcLibDir
+          , "GHC version:           " ++ show ghcVer
           , "Config Location:       " ++ conf
           , "Cradle:                " ++ crdl
           , "Dependencies:          " ++ unwords deps

src/HIE/Bios/Types.hs

@@ -53,14 +53,15 @@ data ActionName a
   deriving (Show, Eq, Ord, Functor)
 
 data CradleAction a = CradleAction {
-                        actionName   :: ActionName a
+                        actionName    :: ActionName a
                       -- ^ Name of the action.
-                      , runCradle    :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+                      , runCradle     :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
                       -- ^ Options to compile the given file with.
-                      , runGhcLibDir :: IO (Maybe FilePath)
-                      -- ^ Try to find the path to /the libdir/ of the GHC that
-                      -- this cradle uses to compile stuff normally. You don't
-                      -- want to call this directly, use 'getGhcLibDir' instead.
+                      -- , runGhcLibDir  :: IO (Maybe FilePath)
+                      -- -- ^ Try to find the path to /the libdir/ of the GHC that
+                      -- -- this cradle uses to compile stuff normally. You don't
+                      -- -- want to call this directly, use 'getGhcLibDir' instead.
+                      , runGhc :: [String] -> IO (Maybe String)
                       }
   deriving (Functor)
 

tests/BiosTests.hs

@@ -106,14 +106,22 @@ testDirectory cradlePred fp step = do
   crd <- initialiseCradle cradlePred a_fp step
   step "Get GHC library directory"
   testGetGhcLibDir crd
+  testGetGhcVersion crd
   step "Initialise Flags"
   testLoadFile crd a_fp step
 
 -- Here we are testing that the cradle's method of obtaining the ghcLibDir
 -- always works.
 testGetGhcLibDir :: Cradle a -> IO ()
 testGetGhcLibDir crd =
-  runGhcLibDir (cradleOptsProg crd) `shouldNotReturn` Nothing
+  getRuntimeGhcLibDir crd True `shouldNotReturn` Nothing
+
+-- Here we are testing that the cradle's method of getting the runtime ghc
+-- version is correct - which while testing, should always be the version that
+-- we have built the tests with!
+testGetGhcVersion :: Cradle a -> IO ()
+testGetGhcVersion crd =
+  getRuntimeGhcVersion crd `shouldReturn` VERSION_ghc
 
 testDirectoryFail :: (Cradle Void -> Bool) -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO ()
 testDirectoryFail cradlePred fp cradleFailPred step = do
@@ -203,7 +211,7 @@ stackYaml resolver = unlines ["resolver: " ++ resolver, "packages:", "- ."]
 stackYamlResolver :: String
 stackYamlResolver =
 #if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)))
-  "TODO"
+  "ghc-8.10.1"
 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)))
   "lts-15.10"
 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,5,0)))