Skip to content

Commit 9ccd9ee

Browse files
pepeiborrapepeiborra
authored
Detect ghc mismatch (#462)
* Detect ghc version mismatches * Add ghc-check to stack extra deps * ghc-check: explicit libdir and delay version error
1 parent f804b13 commit 9ccd9ee

File tree

8 files changed

+128
-52
lines changed

8 files changed

+128
-52
lines changed

‎exe/Rules.hs

+24-47
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE TemplateHaskell #-}
12
module Rules
23
( loadGhcSession
34
, cradleToSession
@@ -13,33 +14,31 @@ import qualified Crypto.Hash.SHA1 as H
1314
import Data.ByteString.Base16 (encode)
1415
import qualified Data.ByteString.Char8 as B
1516
import Data.Functor ((<&>))
16-
import Data.Maybe (fromMaybe)
17-
import Data.Text (pack, Text)
17+
import Data.Text (Text, pack)
18+
import Data.Version (Version)
1819
import Development.IDE.Core.Rules (defineNoFile)
1920
import Development.IDE.Core.Service (getIdeOptions)
2021
import Development.IDE.Core.Shake (actionLogger, sendEvent, define, useNoFile_)
2122
import Development.IDE.GHC.Util
2223
import Development.IDE.Types.Location (fromNormalizedFilePath)
2324
import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting))
2425
import Development.Shake
25-
import DynFlags (gopt_set, gopt_unset,
26-
updOptLevel)
2726
import GHC
28-
import qualified GHC.Paths
27+
import GHC.Check (runTimeVersion, compileTimeVersionFromLibdir)
2928
import HIE.Bios
3029
import HIE.Bios.Cradle
3130
import HIE.Bios.Environment (addCmdOpts)
3231
import HIE.Bios.Types
3332
import Linker (initDynLinker)
3433
import RuleTypes
3534
import qualified System.Directory.Extra as IO
36-
import System.Environment (lookupEnv)
3735
import System.FilePath.Posix (addTrailingPathSeparator,
3836
(</>))
3937
import qualified Language.Haskell.LSP.Messages as LSP
4038
import qualified Language.Haskell.LSP.Types as LSP
4139
import Data.Aeson (ToJSON(toJSON))
4240
import Development.IDE.Types.Logger (logDebug)
41+
import Util
4342

4443
-- Prefix for the cache path
4544
cacheDir :: String
@@ -103,55 +102,33 @@ getComponentOptions cradle = do
103102
-- That will require some more changes.
104103
CradleNone -> fail "'none' cradle is not yet supported"
105104

105+
compileTimeGhcVersion :: Version
106+
compileTimeGhcVersion = $$(compileTimeVersionFromLibdir getLibdir)
107+
108+
checkGhcVersion :: Ghc (Maybe HscEnvEq)
109+
checkGhcVersion = do
110+
v <- runTimeVersion
111+
return $ if v == Just compileTimeGhcVersion
112+
then Nothing
113+
else Just GhcVersionMismatch {compileTime = compileTimeGhcVersion, runTime = v}
114+
106115
createSession :: ComponentOptions -> IO HscEnvEq
107116
createSession (ComponentOptions theOpts _) = do
108117
libdir <- getLibdir
109118

110119
cacheDir <- getCacheDir theOpts
111120

112-
env <- runGhc (Just libdir) $ do
121+
runGhc (Just libdir) $ do
113122
dflags <- getSessionDynFlags
114123
(dflags', _targets) <- addCmdOpts theOpts dflags
115-
_ <- setSessionDynFlags $
116-
-- disabled, generated directly by ghcide instead
117-
flip gopt_unset Opt_WriteInterface $
118-
-- disabled, generated directly by ghcide instead
119-
-- also, it can confuse the interface stale check
120-
dontWriteHieFiles $
121-
setHiDir cacheDir $
122-
setDefaultHieDir cacheDir $
123-
setIgnoreInterfacePragmas $
124-
setLinkerOptions $
125-
disableOptimisation dflags'
126-
getSession
127-
initDynLinker env
128-
newHscEnvEq env
129-
130-
-- Set the GHC libdir to the nix libdir if it's present.
131-
getLibdir :: IO FilePath
132-
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
133-
134-
-- we don't want to generate object code so we compile to bytecode
135-
-- (HscInterpreted) which implies LinkInMemory
136-
-- HscInterpreted
137-
setLinkerOptions :: DynFlags -> DynFlags
138-
setLinkerOptions df = df {
139-
ghcLink = LinkInMemory
140-
, hscTarget = HscNothing
141-
, ghcMode = CompManager
142-
}
143-
144-
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
145-
setIgnoreInterfacePragmas df =
146-
gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
147-
148-
disableOptimisation :: DynFlags -> DynFlags
149-
disableOptimisation df = updOptLevel 0 df
150-
151-
setHiDir :: FilePath -> DynFlags -> DynFlags
152-
setHiDir f d =
153-
-- override user settings to avoid conflicts leading to recompilation
154-
d { hiDir = Just f}
124+
setupDynFlags cacheDir dflags'
125+
versionMismatch <- checkGhcVersion
126+
case versionMismatch of
127+
Just mismatch -> return mismatch
128+
Nothing -> do
129+
env <- getSession
130+
liftIO $ initDynLinker env
131+
liftIO $ newHscEnvEq env
155132

156133
getCacheDir :: [String] -> IO FilePath
157134
getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)

‎exe/Util.hs

+62
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
module Util (setupDynFlags, getLibdir) where
2+
3+
-- Set the GHC libdir to the nix libdir if it's present.
4+
import qualified GHC.Paths as GHCPaths
5+
import DynFlags ( gopt_unset
6+
, GhcMode(CompManager)
7+
, HscTarget(HscNothing)
8+
, GhcLink(LinkInMemory)
9+
, GeneralFlag
10+
( Opt_IgnoreInterfacePragmas
11+
, Opt_IgnoreOptimChanges
12+
, Opt_WriteInterface
13+
)
14+
, gopt_set
15+
, updOptLevel
16+
, DynFlags(..)
17+
)
18+
import Data.Maybe ( fromMaybe )
19+
import Development.IDE.GHC.Util ( setDefaultHieDir
20+
, dontWriteHieFiles
21+
)
22+
import System.Environment ( lookupEnv )
23+
import GHC (GhcMonad, setSessionDynFlags )
24+
import Data.Functor ( void )
25+
26+
setupDynFlags :: GhcMonad f => FilePath -> DynFlags -> f ()
27+
setupDynFlags cacheDir =
28+
void
29+
. setSessionDynFlags
30+
-- disabled, generated directly by ghcide instead
31+
. flip gopt_unset Opt_WriteInterface
32+
-- disabled, generated directly by ghcide instead
33+
-- also, it can confuse the interface stale check
34+
. dontWriteHieFiles
35+
. setHiDir cacheDir
36+
. setDefaultHieDir cacheDir
37+
. setIgnoreInterfacePragmas
38+
. setLinkerOptions
39+
. disableOptimisation
40+
41+
getLibdir :: IO FilePath
42+
getLibdir = fromMaybe GHCPaths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
43+
44+
-- we don't want to generate object code so we compile to bytecode
45+
-- (HscInterpreted) which implies LinkInMemory
46+
47+
-- HscInterpreted
48+
setLinkerOptions :: DynFlags -> DynFlags
49+
setLinkerOptions df =
50+
df { ghcLink = LinkInMemory, hscTarget = HscNothing, ghcMode = CompManager }
51+
52+
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
53+
setIgnoreInterfacePragmas df =
54+
gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
55+
56+
disableOptimisation :: DynFlags -> DynFlags
57+
disableOptimisation df = updOptLevel 0 df
58+
59+
setHiDir :: FilePath -> DynFlags -> DynFlags
60+
setHiDir f d =
61+
-- override user settings to avoid conflicts leading to recompilation
62+
d { hiDir = Just f }

‎ghcide.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -187,6 +187,7 @@ executable ghcide
187187
directory,
188188
extra,
189189
filepath,
190+
ghc-check >= 0.1.0.3,
190191
ghc-paths,
191192
ghc,
192193
gitrev,
@@ -204,6 +205,7 @@ executable ghcide
204205
Paths_ghcide
205206
Rules
206207
RuleTypes
208+
Util
207209

208210
default-extensions:
209211
BangPatterns

‎src/Development/IDE/GHC/Util.hs

+35-5
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
-- | General utility functions, mostly focused around GHC operations.
55
module Development.IDE.GHC.Util(
66
-- * HcsEnv and environment
7-
HscEnvEq, hscEnv, newHscEnvEq,
7+
HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
88
modifyDynFlags,
99
evalGhcEnv,
1010
runGhcEnv,
@@ -35,9 +35,9 @@ import Data.Typeable
3535
import qualified Data.ByteString.Internal as BS
3636
import Fingerprint
3737
import GhcMonad
38-
import GhcPlugins hiding (Unique)
39-
import Data.IORef
4038
import Control.Exception
39+
import Data.IORef
40+
import Data.Version (showVersion, Version)
4141
import FileCleanup
4242
import Foreign.Ptr
4343
import Foreign.ForeignPtr
@@ -57,6 +57,16 @@ import qualified Data.ByteString as BS
5757
import Lexer
5858
import StringBuffer
5959
import System.FilePath
60+
import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
61+
import PackageConfig (PackageConfig)
62+
import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
63+
import Packages (getPackageConfigMap, lookupPackage')
64+
import SrcLoc (mkRealSrcLoc)
65+
import FastString (mkFastString)
66+
import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)
67+
import Module (moduleNameSlashes)
68+
import OccName (parenSymOcc)
69+
import RdrName (nameRdrName, rdrNameOcc)
6070

6171
import Development.IDE.GHC.Compat as GHC
6272
import Development.IDE.Types.Location
@@ -156,27 +166,47 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
156166

157167
-- | An 'HscEnv' with equality. Two values are considered equal
158168
-- if they are created with the same call to 'newHscEnvEq'.
159-
data HscEnvEq = HscEnvEq Unique HscEnv
169+
data HscEnvEq
170+
= HscEnvEq !Unique !HscEnv
171+
| GhcVersionMismatch { compileTime :: !Version
172+
, runTime :: !(Maybe Version)
173+
}
160174

161175
-- | Unwrap an 'HsEnvEq'.
162176
hscEnv :: HscEnvEq -> HscEnv
163-
hscEnv (HscEnvEq _ x) = x
177+
hscEnv = either error id . hscEnv'
178+
179+
hscEnv' :: HscEnvEq -> Either String HscEnv
180+
hscEnv' (HscEnvEq _ x) = Right x
181+
hscEnv' GhcVersionMismatch{..} = Left $
182+
unwords
183+
["ghcide compiled against GHC"
184+
,showVersion compileTime
185+
,"but currently using"
186+
,maybe "an unknown version of GHC" (\v -> "GHC " <> showVersion v) runTime
187+
,". This is unsupported, ghcide must be compiled with the same GHC version as the project."
188+
]
164189

165190
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
166191
newHscEnvEq :: HscEnv -> IO HscEnvEq
167192
newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
168193

169194
instance Show HscEnvEq where
170195
show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
196+
show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
171197

172198
instance Eq HscEnvEq where
173199
HscEnvEq a _ == HscEnvEq b _ = a == b
200+
GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
201+
_ == _ = False
174202

175203
instance NFData HscEnvEq where
176204
rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
205+
rnf GhcVersionMismatch{} = rnf runTime
177206

178207
instance Hashable HscEnvEq where
179208
hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u
209+
hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
180210

181211
-- Fake instance needed to persuade Shake to accept this type as a key.
182212
-- No harm done as ghcide never persists these keys currently

‎stack-ghc-lib.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ extra-deps:
1313
- regex-base-0.94.0.0
1414
- regex-tdfa-1.3.1.0
1515
- haddock-library-1.8.0
16+
- ghc-check-0.1.0.3
1617
nix:
1718
packages: [zlib]
1819
flags:

‎stack.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -14,5 +14,6 @@ extra-deps:
1414
- parser-combinators-1.2.1
1515
- haddock-library-1.8.0
1616
- tasty-rerun-1.1.17
17+
- ghc-check-0.1.0.3
1718
nix:
1819
packages: [zlib]

‎stack84.yaml

+2
Original file line numberDiff line numberDiff line change
@@ -22,11 +22,13 @@ extra-deps:
2222
- unordered-containers-0.2.10.0
2323
- file-embed-0.0.11.2
2424
- heaps-0.3.6.1
25+
- ghc-check-0.1.0.3
2526

2627
# For tasty-retun
2728
- ansi-terminal-0.10.3
2829
- ansi-wl-pprint-0.6.9
2930
- tasty-1.2.3
3031
- tasty-rerun-1.1.17
32+
3133
nix:
3234
packages: [zlib]

‎stack88.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ extra-deps:
55
- haskell-lsp-0.21.0.0
66
- haskell-lsp-types-0.21.0.0
77
- lsp-test-0.10.2.0
8+
- ghc-check-0.1.0.3
89

910
nix:
1011
packages: [zlib]

0 commit comments

Comments
 (0)