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

Commit 249c1fe

Browse files
committed
Find the libdir directory of ghc at run-time
1 parent 7e68832 commit 249c1fe

File tree

8 files changed

+80
-12
lines changed

8 files changed

+80
-12
lines changed

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

Lines changed: 52 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 (IOException, try, catch)
3030
import System.FilePath
3131
import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
3232
import System.Exit
33+
import System.Process (readCreateProcess, shell)
3334

3435
-- | Find the cradle that the given File belongs to.
3536
--
@@ -57,6 +58,54 @@ 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+
80+
getProjectGhcPath :: Cradle -> IO (Maybe FilePath)
81+
getProjectGhcPath crdl = do
82+
isStackInstalled <- isJust <$> findExecutable "stack"
83+
isCabalInstalled <- isJust <$> findExecutable "cabal"
84+
if isStackCradle crdl && isStackInstalled
85+
then
86+
catch (Just <$> tryCommand "stack path --compiler-exe") $ \(_ :: IOException) ->
87+
return Nothing
88+
else if isCabalCradle crdl && isCabalInstalled then do
89+
Just ghcCabalVersion <- catch (Just <$> tryCommand "cabal v2-exec ghc -- --numeric-version") $ \(_ ::IOException) ->
90+
return Nothing
91+
findExecutable ("ghc-" ++ ghcCabalVersion)
92+
else
93+
findExecutable "ghc"
94+
95+
tryCommand :: String -> IO String
96+
tryCommand cmd =
97+
T.unpack . T.strip .T.pack <$> readCreateProcess (shell cmd) ""
98+
99+
getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
100+
getProjectGhcLibDir crdl = do
101+
mGhcPath <- getProjectGhcPath crdl
102+
case mGhcPath of
103+
Nothing -> return Nothing
104+
Just ghcPath -> catch (Just <$> tryCommand (ghcPath ++ " --print-libdir")) $ \(_ :: IOException) -> return Nothing
105+
106+
-- ---------------------------------------------------------------------
107+
108+
60109
{- | Finds a Cabal v2-project, Cabal v1-project or a Stack project
61110
relative to the given FilePath.
62111
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: 9 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,9 @@ 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
146149
-> IO ()
147-
runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
150+
runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do
148151
let dEnv = DispatcherEnv
149152
{ cancelReqsTVar = requestsToCancel
150153
, wipReqsTVar = requestsInProgress
@@ -158,7 +161,11 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
158161

159162
stateVar <- STM.newTVarIO initialState
160163

161-
let runGhcDisp = runIdeGhcM plugins mlf stateVar $
164+
mlibdir <- case mcrdl of
165+
Nothing -> return Nothing
166+
Just crdl -> Bios.getProjectGhcLibDir crdl
167+
168+
let runGhcDisp = runIdeGhcM mlibdir plugins mlf stateVar $
162169
ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut
163170
runIdeDisp = runIdeM plugins mlf stateVar $
164171
ideDispatcher dEnv errorHandler callbackHandler ideChanOut

src/Haskell/Ide/Engine/Server.hs

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -152,10 +152,20 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
152152
(Debounce.forMonoid $ react . dispatchDiagnostics)
153153
(Debounce.def { Debounce.delay = debounceDuration, Debounce.alwaysResetTimer = True })
154154

155+
156+
let lspRootDir = Core.rootPath lf
157+
currentDir <- liftIO getCurrentDirectory
158+
159+
-- Check for mismatching GHC versions
160+
-- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
161+
let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
162+
dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
163+
mcradle <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
164+
155165
-- haskell lsp sets the current directory to the project root in the InitializeRequest
156166
-- We launch the dispatcher after that so that the default cradle is
157167
-- recognized properly by ghc-mod
158-
flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf))
168+
flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle)
159169
flip labelThread "reactor" =<< (forkIO reactorFunc)
160170
flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
161171
return Nothing

test/dispatcher/Main.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,7 @@ startServer = do
7878
(\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e)))
7979
(\g x -> g x)
8080
def
81+
Nothing
8182

8283
return (scheduler, logChan, dispatcher)
8384

test/plugin-dispatcher/Main.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ newPluginSpec = do
4646
(\_ _ _ -> return ())
4747
(\f x -> f x)
4848
def
49+
Nothing
4950

5051
updateDocument scheduler (filePathToUri "test") 3
5152
sendRequest scheduler req0

test/utils/TestUtils.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -74,7 +74,7 @@ makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg)
7474
runIGM :: IdePlugins -> IdeGhcM a -> IO a
7575
runIGM testPlugins f = do
7676
stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing
77-
runIdeGhcM testPlugins Nothing stateVar f
77+
runIdeGhcM Nothing testPlugins Nothing stateVar f
7878

7979
withFileLogging :: FilePath -> IO a -> IO a
8080
withFileLogging logFile f = do

0 commit comments

Comments
 (0)