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

Commit 310450e

Browse files
alanzalanz
authored
Merge pull request #1496 from fendor/dont-depend-on-ghc-at-run-time
Find the libdir directory of ghc at run-time
2 parents 1cbb6ae + fde449b commit 310450e

26 files changed

+295
-175
lines changed

‎haskell-ide-engine.cabal

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -247,6 +247,8 @@ test-suite plugin-dispatcher-test
247247
main-is: Main.hs
248248
build-depends: base
249249
, data-default
250+
, directory
251+
, filepath
250252
, haskell-ide-engine
251253
, haskell-lsp-types
252254
, hie-plugin-api
@@ -289,7 +291,7 @@ test-suite func-test
289291
, data-default
290292
, directory
291293
, filepath
292-
, lsp-test >= 0.9.0.0
294+
, lsp-test >= 0.10.0.0
293295
, haskell-ide-engine
294296
, haskell-lsp-types == 0.19.*
295297
, haskell-lsp == 0.19.*

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

Lines changed: 96 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,19 +17,20 @@ import Distribution.Helper (Package, projectPackages, pUnits,
1717
import Distribution.Helper.Discover (findProjects, getDefaultDistDir)
1818
import Data.Char (toLower)
1919
import Data.Function ((&))
20-
import Data.List (isPrefixOf, isInfixOf)
20+
import Data.List (isPrefixOf, isInfixOf, sortOn, find)
2121
import qualified Data.List.NonEmpty as NonEmpty
2222
import Data.List.NonEmpty (NonEmpty)
2323
import qualified Data.Map as M
24-
import Data.List (sortOn, find)
2524
import Data.Maybe (listToMaybe, mapMaybe, isJust)
2625
import Data.Ord (Down(..))
2726
import Data.String (IsString(..))
27+
import qualified Data.Text as T
2828
import Data.Foldable (toList)
29-
import Control.Exception (IOException, try)
29+
import Control.Exception
3030
import System.FilePath
3131
import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
3232
import System.Exit
33+
import System.Process (readCreateProcessWithExitCode, shell)
3334

3435
-- | Find the cradle that the given File belongs to.
3536
--
@@ -57,6 +58,98 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None
5758
. BIOS.actionName
5859
. BIOS.cradleOptsProg
5960

61+
-- | Check if the given cradle is a cabal cradle.
62+
-- This might be used to determine the GHC version to use on the project.
63+
-- If it is a stack-cradle, we have to use `stack path --compiler-exe`
64+
-- otherwise we may ask `ghc` directly what version it is.
65+
isCabalCradle :: Cradle -> Bool
66+
isCabalCradle =
67+
(`elem`
68+
["cabal"
69+
, "Cabal-Helper-Cabal-V1"
70+
, "Cabal-Helper-Cabal-V2"
71+
, "Cabal-Helper-Cabal-V1-Dir"
72+
, "Cabal-Helper-Cabal-V2-Dir"
73+
, "Cabal-Helper-Cabal-None"
74+
]
75+
)
76+
. BIOS.actionName
77+
. BIOS.cradleOptsProg
78+
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
88+
isStackInstalled <- isJust <$> findExecutable "stack"
89+
-- isCabalInstalled <- isJust <$> findExecutable "cabal"
90+
ghcOutput <- if isStackCradle crdl && isStackInstalled
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
106+
else do
107+
logm "Use Plain GHC"
108+
execWithGhc
109+
debugm $ "GHC Output: \"" ++ show ghcOutput ++ "\""
110+
return ghcOutput
111+
where
112+
stackCmd = "stack ghc -- " ++ unwords args
113+
plainCmd = "ghc " ++ unwords args
114+
115+
execWithGhc =
116+
catch (Just <$> tryCommand plainCmd) $ \(_ :: IOException) -> do
117+
errorm $ "Command `" ++ plainCmd ++"` failed."
118+
return Nothing
119+
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.
142+
getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
143+
getProjectGhcLibDir crdl =
144+
execProjectGhc crdl ["--print-libdir"] >>= \case
145+
Nothing -> do
146+
logm "Could not obtain the libdir."
147+
return Nothing
148+
mlibdir -> return mlibdir
149+
150+
-- ---------------------------------------------------------------------
151+
152+
60153
{- | Finds a Cabal v2-project, Cabal v1-project or a Stack project
61154
relative to the given FilePath.
62155
Cabal v2-project and Stack have priority over Cabal v1-project.

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

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -120,9 +120,8 @@ import Data.Typeable ( TypeRep
120120
)
121121
import System.Directory
122122
import GhcMonad
123-
import qualified HIE.Bios.Ghc.Api as BIOS
124123
import GHC.Generics
125-
import GHC ( HscEnv )
124+
import GHC ( HscEnv, runGhcT )
126125
import Exception
127126

128127
import Haskell.Ide.Engine.Compat
@@ -345,10 +344,10 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c)
345344
type IdeGhcM = GhcT IdeM
346345

347346
-- | Run an IdeGhcM with Cradle found from the current directory
348-
runIdeGhcM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
349-
runIdeGhcM plugins mlf stateVar f = do
347+
runIdeGhcM :: Maybe FilePath -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
348+
runIdeGhcM mlibdir plugins mlf stateVar f = do
350349
env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
351-
flip runReaderT stateVar $ flip runReaderT env $ BIOS.withGhcT f
350+
flip runReaderT stateVar $ flip runReaderT env $ runGhcT mlibdir f
352351

353352
-- | A computation that is deferred until the module is cached.
354353
-- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed

‎hie-plugin-api/hie-plugin-api.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ library
5656
, unliftio
5757
, monad-control
5858
, mtl
59+
, process
5960
, stm
6061
, syb
6162
, text

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

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,9 @@ import qualified Language.Haskell.LSP.Core as Core
4141
import qualified Language.Haskell.LSP.Types as J
4242
import GhcMonad
4343

44+
import qualified HIE.Bios.Types as Bios
4445
import Haskell.Ide.Engine.GhcModuleCache
46+
import qualified Haskell.Ide.Engine.Cradle as Bios
4547
import Haskell.Ide.Engine.Config
4648
import qualified Haskell.Ide.Engine.Channel as Channel
4749
import Haskell.Ide.Engine.PluginsIdeMonads
@@ -143,8 +145,11 @@ runScheduler
143145
-- ^ A handler to run the requests' callback in your monad of choosing.
144146
-> Maybe (Core.LspFuncs Config)
145147
-- ^ The LspFuncs provided by haskell-lsp, if using LSP.
148+
-> Maybe Bios.Cradle
149+
-- ^ Context in which the ghc thread is executed.
150+
-- Neccessary to obtain the libdir, for example.
146151
-> IO ()
147-
runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
152+
runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do
148153
let dEnv = DispatcherEnv
149154
{ cancelReqsTVar = requestsToCancel
150155
, wipReqsTVar = requestsInProgress
@@ -158,7 +163,11 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
158163

159164
stateVar <- STM.newTVarIO initialState
160165

161-
let runGhcDisp = runIdeGhcM plugins mlf stateVar $
166+
mlibdir <- case mcrdl of
167+
Nothing -> return Nothing
168+
Just crdl -> Bios.getProjectGhcLibDir crdl
169+
170+
let runGhcDisp = runIdeGhcM mlibdir plugins mlf stateVar $
162171
ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut
163172
runIdeDisp = runIdeM plugins mlf stateVar $
164173
ideDispatcher dEnv errorHandler callbackHandler ideChanOut

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

Lines changed: 57 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,8 @@ import qualified Data.SortedList as SL
3838
import qualified Data.Text as T
3939
import Data.Text.Encoding
4040
import qualified Data.Yaml as Yaml
41-
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
41+
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay
42+
, isCabalCradle)
4243
import Haskell.Ide.Engine.Config
4344
import qualified Haskell.Ide.Engine.Ghc as HIE
4445
import Haskell.Ide.Engine.CodeActions
@@ -151,12 +152,64 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
151152
(Debounce.forMonoid $ react . dispatchDiagnostics)
152153
(Debounce.def { Debounce.delay = debounceDuration, Debounce.alwaysResetTimer = True })
153154

155+
156+
let lspRootDir = Core.rootPath lf
157+
currentDir <- liftIO getCurrentDirectory
158+
159+
-- Check for mismatching GHC versions
160+
let dummyCradleFile = fromMaybe currentDir lspRootDir </> "File.hs"
161+
debugm $ "Dummy Cradle file result: " ++ dummyCradleFile
162+
cradleRes <- liftIO $ E.try (findLocalCradle dummyCradleFile)
163+
let sf = Core.sendFunc lf
164+
165+
case cradleRes of
166+
Right cradle -> do
167+
projGhcVersion <- liftIO $ getProjectGhcVersion cradle
168+
when (projGhcVersion /= hieGhcVersion) $ do
169+
let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
170+
" is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
171+
++ "\nYou may want to use hie-wrapper. Check the README for more information"
172+
sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
173+
sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
174+
175+
-- Check cabal is installed
176+
when (isCabalCradle cradle) $ do
177+
hasCabal <- liftIO checkCabalInstall
178+
unless hasCabal $ do
179+
let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information"
180+
sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
181+
sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
182+
183+
Left (e :: Yaml.ParseException) -> do
184+
logm $ "Failed to parse `hie.yaml`: " ++ show e
185+
sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError ("Couldn't parse hie.yaml: \n" <> T.pack (show e))
186+
187+
let mcradle = case cradleRes of
188+
Left _ -> Nothing
189+
Right c -> Just c
190+
154191
-- haskell lsp sets the current directory to the project root in the InitializeRequest
155192
-- We launch the dispatcher after that so that the default cradle is
156193
-- recognized properly by ghc-mod
157-
flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf))
158-
flip labelThread "reactor" =<< (forkIO reactorFunc)
159-
flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
194+
flip labelThread "scheduler" =<<
195+
(forkIO (
196+
Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle
197+
`E.catch` \(e :: E.SomeException) ->
198+
(errorm $ "Scheduler thread exited unexpectedly: " ++ show e)
199+
))
200+
flip labelThread "reactor" =<<
201+
(forkIO (
202+
reactorFunc
203+
`E.catch` \(e :: E.SomeException) ->
204+
(errorm $ "Reactor thread exited unexpectedly: " ++ show e)
205+
))
206+
flip labelThread "diagnostics" =<<
207+
(forkIO (
208+
diagnosticsQueue tr
209+
`E.catch` \(e :: E.SomeException) ->
210+
(errorm $ "Diagnostic thread exited unexpectedly: " ++ show e)
211+
))
212+
160213
return Nothing
161214

162215
diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
@@ -396,35 +449,6 @@ reactor inp diagIn = do
396449
reactorSend $ NotLogMessage $
397450
fmServerLogMessageNotification J.MtLog $ "Using hie version: " <> T.pack hieVersion
398451

399-
lspRootDir <- asksLspFuncs Core.rootPath
400-
currentDir <- liftIO getCurrentDirectory
401-
402-
-- Check for mismatching GHC versions
403-
-- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
404-
let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
405-
dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
406-
cradleRes <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
407-
408-
case cradleRes of
409-
Just cradle -> do
410-
projGhcVersion <- liftIO $ getProjectGhcVersion cradle
411-
when (projGhcVersion /= hieGhcVersion) $ do
412-
let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
413-
" is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
414-
++ "\nYou may want to use hie-wrapper. Check the README for more information"
415-
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
416-
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
417-
418-
-- Check cabal is installed
419-
-- TODO: only do this check if its a cabal cradle
420-
hasCabal <- liftIO checkCabalInstall
421-
unless hasCabal $ do
422-
let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information"
423-
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
424-
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
425-
426-
Nothing -> return ()
427-
428452
renv <- ask
429453
let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb
430454
callback Nothing = flip runReaderT renv $

0 commit comments

Comments
 (0)