Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit bacc594

Browse files
fendorfendor
committed
Express getProjectGhcVersion with execProjectGhc
Fallback to normal ghc if stack fails
1 parent afb2ca3 commit bacc594

File tree

3 files changed

+92
-83
lines changed

3 files changed

+92
-83
lines changed

‎hie-plugin-api/Haskell/Ide/Engine/Cradle.hs

+65-31
Original file line numberDiff line numberDiff line change
@@ -26,11 +26,11 @@ import Data.Ord (Down(..))
2626
import Data.String (IsString(..))
2727
import qualified Data.Text as T
2828
import Data.Foldable (toList)
29-
import Control.Exception (IOException, try, catch)
29+
import Control.Exception
3030
import System.FilePath
3131
import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
3232
import System.Exit
33-
import System.Process (readCreateProcess, shell)
33+
import System.Process (readCreateProcessWithExitCode, shell)
3434

3535
-- | Find the cradle that the given File belongs to.
3636
--
@@ -76,42 +76,76 @@ isCabalCradle =
7676
. BIOS.actionName
7777
. BIOS.cradleOptsProg
7878

79-
80-
getProjectGhcPath :: Cradle -> IO (Maybe FilePath)
81-
getProjectGhcPath crdl = do
79+
-- | Execute @ghc@ that is based on the given cradle.
80+
-- Output must be a single line. If an error is raised, e.g. the command
81+
-- failed, a @Nothing@ is returned.
82+
-- The exact error is written to logs.
83+
--
84+
-- E.g. for a stack cradle, we use `stack ghc` and for a cabal cradle
85+
-- we are taking the @ghc@ that is on the path.
86+
execProjectGhc :: Cradle -> [String] -> IO (Maybe String)
87+
execProjectGhc crdl args = do
8288
isStackInstalled <- isJust <$> findExecutable "stack"
83-
isCabalInstalled <- isJust <$> findExecutable "cabal"
89+
-- isCabalInstalled <- isJust <$> findExecutable "cabal"
8490
ghcpath <- if isStackCradle crdl && isStackInstalled
85-
then
86-
catch (Just <$> tryCommand "stack path --compiler-exe") $ \(_ :: IOException) -> do
87-
errorm "Command `stack path --compiler-exe` failed."
88-
return Nothing
89-
else if isCabalCradle crdl && isCabalInstalled then do
90-
ghcCabalVersion <- catch (Just <$> tryCommand "cabal v2-exec -v0 ghc -- --numeric-version") $ \(_ ::IOException) -> do
91-
errorm "Command `cabal v2-exec -v0 ghc -- --numeric-version` failed."
92-
return Nothing
93-
case ghcCabalVersion of
94-
Just ghcNumericVersion -> do
95-
let ghcVersion = "ghc-" ++ ghcNumericVersion
96-
logm $ "Ghc Version to find: " ++ ghcVersion
97-
findExecutable ghcVersion
98-
Nothing -> return Nothing
91+
then do
92+
logm "Use Stack GHC"
93+
catch (Just <$> tryCommand stackCmd) $ \(_ :: IOException) -> do
94+
errorm $ "Command `" ++ stackCmd ++"` failed."
95+
execWithGhc
96+
-- The command `cabal v2-exec -v0 ghc` only works if the project has been
97+
-- built already.
98+
-- This command must work though before the project is build.
99+
-- Therefore, fallback to "ghc" on the path.
100+
--
101+
-- else if isCabalCradle crdl && isCabalInstalled then do
102+
-- let cmd = "cabal v2-exec -v0 ghc -- " ++ unwords args
103+
-- catch (Just <$> tryCommand cmd) $ \(_ ::IOException) -> do
104+
-- errorm $ "Command `" ++ cmd ++ "` failed."
105+
-- return Nothing
99106
else do
100-
logm "Neither cabal nor stack project, look for ghc project."
101-
findExecutable "ghc"
102-
logm $ "Found ghc path: " ++ show ghcpath
107+
logm "Use Plain GHC"
108+
execWithGhc
109+
debugm $ "Output from: " ++ show ghcpath
103110
return ghcpath
111+
where
112+
stackCmd = "stack ghc -- " ++ unwords args
113+
plainCmd = "ghc " ++ unwords args
104114

105-
tryCommand :: String -> IO String
106-
tryCommand cmd =
107-
T.unpack . T.strip .T.pack <$> readCreateProcess (shell cmd) ""
115+
execWithGhc =
116+
catch (Just <$> tryCommand plainCmd) $ \(_ :: IOException) -> do
117+
errorm $ "Command `" ++ plainCmd ++"` failed."
118+
return Nothing
108119

120+
tryCommand :: String -> IO String
121+
tryCommand cmd = do
122+
(code, sout, serr) <- readCreateProcessWithExitCode (shell cmd) ""
123+
case code of
124+
ExitFailure e -> do
125+
let errmsg = concat
126+
[ "`"
127+
, cmd
128+
, "`: Exit failure: "
129+
, show e
130+
, ", stdout: "
131+
, sout
132+
, ", stderr: "
133+
, serr
134+
]
135+
errorm errmsg
136+
throwIO $ userError errmsg
137+
138+
ExitSuccess -> return $ T.unpack . T.strip . head . T.lines $ T.pack sout
139+
140+
141+
-- | Get the directory of the libdir based on the project ghc.
109142
getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
110-
getProjectGhcLibDir crdl = do
111-
mGhcPath <- getProjectGhcPath crdl
112-
case mGhcPath of
113-
Nothing -> return Nothing
114-
Just ghcPath -> catch (Just <$> tryCommand (ghcPath ++ " --print-libdir")) $ \(_ :: IOException) -> return Nothing
143+
getProjectGhcLibDir crdl =
144+
catch
145+
(execProjectGhc crdl ["--print-libdir"])
146+
$ \(_ :: IOException) -> do
147+
logm "Could not obtain the libdir."
148+
return Nothing
115149

116150
-- ---------------------------------------------------------------------
117151

‎src/Haskell/Ide/Engine/Server.hs

+19-3
Original file line numberDiff line numberDiff line change
@@ -167,9 +167,25 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
167167
-- haskell lsp sets the current directory to the project root in the InitializeRequest
168168
-- We launch the dispatcher after that so that the default cradle is
169169
-- recognized properly by ghc-mod
170-
flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle)
171-
flip labelThread "reactor" =<< (forkIO reactorFunc)
172-
flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
170+
flip labelThread "scheduler" =<<
171+
(forkIO (
172+
Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle
173+
`E.catch` \(e :: E.SomeException) ->
174+
(errorm $ "Scheduler thread exited unexpectedly: " ++ show e)
175+
))
176+
flip labelThread "reactor" =<<
177+
(forkIO (
178+
reactorFunc
179+
`E.onException`
180+
errorm "Reactor thread exited unexpectedly"
181+
))
182+
flip labelThread "diagnostics" =<<
183+
(forkIO (
184+
diagnosticsQueue tr
185+
`E.onException`
186+
errorm "diagnostics thread exited unexpectedly"
187+
))
188+
173189
return Nothing
174190

175191
diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]

‎src/Haskell/Ide/Engine/Version.hs

+8-49
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,21 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE TemplateHaskell #-}
3+
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE OverloadedStrings #-}
45
-- | Information and display strings for HIE's version
56
-- and the current project's version
67
module Haskell.Ide.Engine.Version where
78

8-
import Control.Exception
99
import Data.Maybe
1010
import Development.GitRev (gitCommitCount)
1111
import Distribution.System (buildArch)
1212
import Distribution.Text (display)
1313
import Options.Applicative.Simple (simpleVersion)
14-
import Haskell.Ide.Engine.Cradle (isStackCradle)
15-
import qualified HIE.Bios.Types as BIOS
14+
import Haskell.Ide.Engine.Cradle (execProjectGhc)
15+
import qualified HIE.Bios.Types as Bios
1616
import qualified Paths_haskell_ide_engine as Meta
17-
import qualified System.Log.Logger as L
18-
import qualified Data.Text as T
19-
import qualified Data.Versions as V
2017
import System.Directory
2118
import System.Info
22-
import System.Process
2319

2420
hieVersion :: String
2521
hieVersion =
@@ -39,55 +35,18 @@ hieVersion =
3935
hieGhcDisplayVersion :: String
4036
hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc
4137

42-
getProjectGhcVersion :: BIOS.Cradle -> IO String
43-
getProjectGhcVersion crdl = do
44-
isStackInstalled <- isJust <$> findExecutable "stack"
45-
if isStackCradle crdl && isStackInstalled
46-
then do
47-
L.infoM "hie" "Using stack GHC version"
48-
catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do
49-
L.errorM "hie" $ show (e :: SomeException)
50-
L.infoM "hie" "Couldn't find stack version, falling back to plain GHC"
51-
getGhcVersion
52-
else do
53-
L.infoM "hie" "Using plain GHC version"
54-
getGhcVersion
38+
getProjectGhcVersion :: Bios.Cradle -> IO String
39+
getProjectGhcVersion crdl =
40+
execProjectGhc crdl ["--numeric-version"] >>= \case
41+
Just version -> return version
42+
Nothing -> return "No System GHC Found."
5543

56-
where
57-
getGhcVersion = do
58-
isGhcInstalled <- isJust <$> findExecutable "ghc"
59-
if isGhcInstalled
60-
then tryCommand "ghc --numeric-version"
61-
else return "No System GHC found"
62-
63-
64-
tryCommand :: String -> IO String
65-
tryCommand cmd =
66-
init <$> readCreateProcess (shell cmd) ""
6744

6845
hieGhcVersion :: String
6946
hieGhcVersion = VERSION_ghc
7047

7148
-- ---------------------------------------------------------------------
7249

73-
getStackVersion :: IO (Maybe V.Version)
74-
getStackVersion = do
75-
isStackInstalled <- isJust <$> findExecutable "stack"
76-
if isStackInstalled
77-
then do
78-
versionStr <- tryCommand "stack --numeric-version"
79-
case V.version (T.pack versionStr) of
80-
Left _err -> return Nothing
81-
Right v -> return (Just v)
82-
else return Nothing
83-
84-
stack193Version :: V.Version
85-
stack193Version = case V.version "1.9.3" of
86-
Left err -> error $ "stack193Version:err=" ++ show err
87-
Right v -> v
88-
89-
-- ---------------------------------------------------------------------
90-
9150
checkCabalInstall :: IO Bool
9251
checkCabalInstall = isJust <$> findExecutable "cabal"
9352

0 commit comments

Comments
 (0)