Detect ghc mismatch (#462)

* Detect ghc version mismatches

* Add ghc-check to stack extra deps

* ghc-check: explicit libdir and delay version error

exe/Rules.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Rules
   ( loadGhcSession
   , cradleToSession
@@ -13,33 +14,31 @@ import qualified Crypto.Hash.SHA1               as H
 import           Data.ByteString.Base16         (encode)
 import qualified Data.ByteString.Char8          as B
 import           Data.Functor                   ((<&>))
-import           Data.Maybe                     (fromMaybe)
-import           Data.Text                      (pack, Text)
+import           Data.Text                      (Text, pack)
+import           Data.Version                   (Version)
 import           Development.IDE.Core.Rules     (defineNoFile)
 import           Development.IDE.Core.Service   (getIdeOptions)
 import           Development.IDE.Core.Shake     (actionLogger, sendEvent, define, useNoFile_)
 import           Development.IDE.GHC.Util
 import           Development.IDE.Types.Location (fromNormalizedFilePath)
 import           Development.IDE.Types.Options  (IdeOptions(IdeOptions, optTesting))
 import           Development.Shake
-import           DynFlags                       (gopt_set, gopt_unset,
-                                                 updOptLevel)
 import           GHC
-import qualified GHC.Paths
+import           GHC.Check                      (runTimeVersion, compileTimeVersionFromLibdir)
 import           HIE.Bios
 import           HIE.Bios.Cradle
 import           HIE.Bios.Environment           (addCmdOpts)
 import           HIE.Bios.Types
 import           Linker                         (initDynLinker)
 import           RuleTypes
 import qualified System.Directory.Extra         as IO
-import           System.Environment             (lookupEnv)
 import           System.FilePath.Posix          (addTrailingPathSeparator,
                                                  (</>))
 import qualified Language.Haskell.LSP.Messages  as LSP
 import qualified Language.Haskell.LSP.Types     as LSP
 import Data.Aeson (ToJSON(toJSON))
 import Development.IDE.Types.Logger (logDebug)
+import Util
 
 -- Prefix for the cache path
 cacheDir :: String
@@ -103,55 +102,33 @@ getComponentOptions cradle = do
         -- That will require some more changes.
         CradleNone      -> fail "'none' cradle is not yet supported"
 
+compileTimeGhcVersion :: Version
+compileTimeGhcVersion = $$(compileTimeVersionFromLibdir getLibdir)
+
+checkGhcVersion :: Ghc (Maybe HscEnvEq)
+checkGhcVersion = do
+    v <- runTimeVersion
+    return $ if v == Just compileTimeGhcVersion
+        then Nothing
+        else Just GhcVersionMismatch {compileTime = compileTimeGhcVersion, runTime = v}
+
 createSession :: ComponentOptions -> IO HscEnvEq
 createSession (ComponentOptions theOpts _) = do
     libdir <- getLibdir
 
     cacheDir <- getCacheDir theOpts
 
-    env <- runGhc (Just libdir) $ do
+    runGhc (Just libdir) $ do
         dflags <- getSessionDynFlags
         (dflags', _targets) <- addCmdOpts theOpts dflags
-        _ <- setSessionDynFlags $
-             -- disabled, generated directly by ghcide instead
-             flip gopt_unset Opt_WriteInterface $
-             -- disabled, generated directly by ghcide instead
-             -- also, it can confuse the interface stale check
-             dontWriteHieFiles $
-             setHiDir cacheDir $
-             setDefaultHieDir cacheDir $
-             setIgnoreInterfacePragmas $
-             setLinkerOptions $
-             disableOptimisation dflags'
-        getSession
-    initDynLinker env
-    newHscEnvEq env
-
--- Set the GHC libdir to the nix libdir if it's present.
-getLibdir :: IO FilePath
-getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
-
--- we don't want to generate object code so we compile to bytecode
--- (HscInterpreted) which implies LinkInMemory
--- HscInterpreted
-setLinkerOptions :: DynFlags -> DynFlags
-setLinkerOptions df = df {
-    ghcLink   = LinkInMemory
-  , hscTarget = HscNothing
-  , ghcMode = CompManager
-  }
-
-setIgnoreInterfacePragmas :: DynFlags -> DynFlags
-setIgnoreInterfacePragmas df =
-    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
-
-disableOptimisation :: DynFlags -> DynFlags
-disableOptimisation df = updOptLevel 0 df
-
-setHiDir :: FilePath -> DynFlags -> DynFlags
-setHiDir f d =
-    -- override user settings to avoid conflicts leading to recompilation
-    d { hiDir      = Just f}
+        setupDynFlags cacheDir dflags'
+        versionMismatch <- checkGhcVersion
+        case versionMismatch of
+            Just mismatch -> return mismatch
+            Nothing ->  do
+                env <- getSession
+                liftIO $ initDynLinker env
+                liftIO $ newHscEnvEq env
 
 getCacheDir :: [String] -> IO FilePath
 getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)

exe/Util.hs

@@ -0,0 +1,62 @@
+module Util (setupDynFlags, getLibdir) where
+
+-- Set the GHC libdir to the nix libdir if it's present.
+import qualified GHC.Paths                     as GHCPaths
+import           DynFlags                       ( gopt_unset
+                                                , GhcMode(CompManager)
+                                                , HscTarget(HscNothing)
+                                                , GhcLink(LinkInMemory)
+                                                , GeneralFlag
+                                                  ( Opt_IgnoreInterfacePragmas
+                                                  , Opt_IgnoreOptimChanges
+                                                  , Opt_WriteInterface
+                                                  )
+                                                , gopt_set
+                                                , updOptLevel
+                                                , DynFlags(..)
+                                                )
+import           Data.Maybe                     ( fromMaybe )
+import           Development.IDE.GHC.Util       ( setDefaultHieDir
+                                                , dontWriteHieFiles
+                                                )
+import           System.Environment             ( lookupEnv )
+import           GHC                            (GhcMonad, setSessionDynFlags )
+import           Data.Functor                   ( void )
+
+setupDynFlags :: GhcMonad f => FilePath -> DynFlags -> f ()
+setupDynFlags cacheDir =
+  void
+    . setSessionDynFlags
+    -- disabled, generated directly by ghcide instead
+    . flip gopt_unset Opt_WriteInterface
+    -- disabled, generated directly by ghcide instead
+    -- also, it can confuse the interface stale check
+    . dontWriteHieFiles
+    . setHiDir cacheDir
+    . setDefaultHieDir cacheDir
+    . setIgnoreInterfacePragmas
+    . setLinkerOptions
+    . disableOptimisation
+
+getLibdir :: IO FilePath
+getLibdir = fromMaybe GHCPaths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
+
+-- we don't want to generate object code so we compile to bytecode
+-- (HscInterpreted) which implies LinkInMemory
+
+-- HscInterpreted
+setLinkerOptions :: DynFlags -> DynFlags
+setLinkerOptions df =
+  df { ghcLink = LinkInMemory, hscTarget = HscNothing, ghcMode = CompManager }
+
+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
+setIgnoreInterfacePragmas df =
+  gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
+
+disableOptimisation :: DynFlags -> DynFlags
+disableOptimisation df = updOptLevel 0 df
+
+setHiDir :: FilePath -> DynFlags -> DynFlags
+setHiDir f d =
+    -- override user settings to avoid conflicts leading to recompilation
+  d { hiDir = Just f }

ghcide.cabal

@@ -187,6 +187,7 @@ executable ghcide
         directory,
         extra,
         filepath,
+        ghc-check >= 0.1.0.3,
         ghc-paths,
         ghc,
         gitrev,
@@ -204,6 +205,7 @@ executable ghcide
         Paths_ghcide
         Rules
         RuleTypes
+        Util
 
     default-extensions:
         BangPatterns

src/Development/IDE/GHC/Util.hs

@@ -4,7 +4,7 @@
 -- | General utility functions, mostly focused around GHC operations.
 module Development.IDE.GHC.Util(
     -- * HcsEnv and environment
-    HscEnvEq, hscEnv, newHscEnvEq,
+    HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
     modifyDynFlags,
     evalGhcEnv,
     runGhcEnv,
@@ -35,9 +35,9 @@ import Data.Typeable
 import qualified Data.ByteString.Internal as BS
 import Fingerprint
 import GhcMonad
-import GhcPlugins hiding (Unique)
-import Data.IORef
 import Control.Exception
+import Data.IORef
+import Data.Version (showVersion, Version)
 import FileCleanup
 import Foreign.Ptr
 import Foreign.ForeignPtr
@@ -57,6 +57,16 @@ import qualified Data.ByteString          as BS
 import Lexer
 import StringBuffer
 import System.FilePath
+import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
+import PackageConfig (PackageConfig)
+import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
+import Packages (getPackageConfigMap, lookupPackage')
+import SrcLoc (mkRealSrcLoc)
+import FastString (mkFastString)
+import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)
+import Module (moduleNameSlashes)
+import OccName (parenSymOcc)
+import RdrName (nameRdrName, rdrNameOcc)
 
 import Development.IDE.GHC.Compat as GHC
 import Development.IDE.Types.Location
@@ -156,27 +166,47 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
 
 -- | An 'HscEnv' with equality. Two values are considered equal
 --   if they are created with the same call to 'newHscEnvEq'.
-data HscEnvEq = HscEnvEq Unique HscEnv
+data HscEnvEq
+    = HscEnvEq !Unique !HscEnv
+    | GhcVersionMismatch { compileTime :: !Version
+                         , runTime     :: !(Maybe Version)
+                         }
 
 -- | Unwrap an 'HsEnvEq'.
 hscEnv :: HscEnvEq -> HscEnv
-hscEnv (HscEnvEq _ x) = x
+hscEnv = either error id . hscEnv'
+
+hscEnv' :: HscEnvEq -> Either String HscEnv
+hscEnv' (HscEnvEq _ x) = Right x
+hscEnv' GhcVersionMismatch{..} = Left $
+    unwords
+        ["ghcide compiled against GHC"
+        ,showVersion compileTime
+        ,"but currently using"
+        ,maybe "an unknown version of GHC" (\v -> "GHC " <> showVersion v) runTime
+        ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."
+        ]
 
 -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
 newHscEnvEq :: HscEnv -> IO HscEnvEq
 newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
 
 instance Show HscEnvEq where
   show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
+  show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
 
 instance Eq HscEnvEq where
   HscEnvEq a _ == HscEnvEq b _ = a == b
+  GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
+  _ == _ = False
 
 instance NFData HscEnvEq where
   rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
+  rnf GhcVersionMismatch{} = rnf runTime
 
 instance Hashable HscEnvEq where
   hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u
+  hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
 
 -- Fake instance needed to persuade Shake to accept this type as a key.
 -- No harm done as ghcide never persists these keys currently

stack-ghc-lib.yaml

@@ -13,6 +13,7 @@ extra-deps:
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0
 - haddock-library-1.8.0
+- ghc-check-0.1.0.3
 nix:
   packages: [zlib]
 flags:

stack.yaml

@@ -14,5 +14,6 @@ extra-deps:
 - parser-combinators-1.2.1
 - haddock-library-1.8.0
 - tasty-rerun-1.1.17
+- ghc-check-0.1.0.3
 nix:
   packages: [zlib]

stack84.yaml

@@ -22,11 +22,13 @@ extra-deps:
 - unordered-containers-0.2.10.0
 - file-embed-0.0.11.2
 - heaps-0.3.6.1
+- ghc-check-0.1.0.3
 
 # For tasty-retun
 - ansi-terminal-0.10.3
 - ansi-wl-pprint-0.6.9
 - tasty-1.2.3
 - tasty-rerun-1.1.17
+
 nix:
   packages: [zlib]

stack88.yaml

@@ -5,6 +5,7 @@ extra-deps:
 - haskell-lsp-0.21.0.0
 - haskell-lsp-types-0.21.0.0
 - lsp-test-0.10.2.0
+- ghc-check-0.1.0.3
 
 nix:
   packages: [zlib]