Add GHC version check

1 files changed, 72 insertions, 2 deletions

diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs
index fc09915..8ba3abd 100644
--- a/src/HaskellCodeExplorer/PackageInfo.hs
+++ b/src/HaskellCodeExplorer/PackageInfo.hs
@@ -10,6 +10,7 @@
 
 module HaskellCodeExplorer.PackageInfo
   ( createPackageInfo
+  , ghcVersion
   ) where
 
 import Control.DeepSeq(deepseq)
@@ -32,6 +33,7 @@ import Control.Monad.Logger
   , logInfoN
   )
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
 import qualified Data.HashMap.Strict as HM
 import Data.IORef (readIORef)
 import qualified Data.IntMap.Strict as IM
@@ -40,6 +42,8 @@ import Data.Maybe (fromMaybe, isJust, maybeToList)
 import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import Data.Version (Version(..), showVersion, parseVersion)
+import Text.ParserCombinators.ReadP (readP_to_S)
 import Digraph (flattenSCCs)
 import Distribution.Helper
   ( ChComponentName(..)
@@ -102,6 +106,7 @@ import System.Directory
   , makeAbsolute
   )
 import qualified System.Directory.Tree as DT
+import System.Exit (exitFailure)
 import System.FilePath
   ( (</>)
   , addTrailingPathSeparator
@@ -115,7 +120,7 @@ import System.FilePath
   , splitDirectories  
   )
 import System.FilePath.Find
-import System.Exit (exitFailure)
+import System.IO (IOMode(..), withFile)
 import System.Process (readProcess)
 
 createPackageInfo ::
@@ -138,6 +143,18 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
           Right distDir -> return distDir
           Left errorMessage ->
             logErrorN (T.pack errorMessage) >> liftIO exitFailure
+  eitherPackageGhcVersion <- liftIO $ getPackageGhcVersion distDir
+  case eitherPackageGhcVersion of
+    Right packageGhcVersion ->
+      if take 2 (versionBranch packageGhcVersion) == take 2 (versionBranch ghcVersion)
+        then return ()
+        else let message =
+                   "GHC version mismatch. haskell-code-indexer: " ++
+                   showVersion ghcVersion ++
+                   ", package: " ++
+                   showVersion packageGhcVersion
+              in logErrorN (T.pack message) >> liftIO exitFailure
+    Left err -> logErrorN (T.pack err) >> liftIO exitFailure
   let cabalHelperQueryEnv = mkQueryEnv packageDirectoryAbsPath distDir
   ((packageName, packageVersion), compInfo) <-
     liftIO $
@@ -248,7 +265,60 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
     chComponentNameToComponentId (ChBenchName name) =
       HCE.ComponentId . T.append "bench-" . T.pack $ name
     chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup"
-     
+
+-- | Parses the header of setup-config file.
+-- The header is generated by Cabal:
+-- https://github.com/haskell/cabal/blob/5be57c0d251be40a6263cd996d99703b8de1ed79/Cabal/Distribution/Simple/Configure.hs#L286-L295
+getPackageGhcVersion :: FilePath -> IO (Either String Version)
+getPackageGhcVersion distDir =
+  withFile (distDir </> "setup-config") ReadMode $ \handle -> do
+    header <- BSC.hGetLine handle
+    let parseHeader :: BSC.ByteString -> Maybe BSC.ByteString
+        parseHeader hdr =
+          case BSC.words hdr of
+            ["Saved", "package", "config", "for", _package, "written", "by", _cabal, "using", compiler] ->
+              Just compiler
+            _ -> Nothing
+        parseCompiler :: BSC.ByteString -> Maybe BSC.ByteString
+        parseCompiler compiler =
+          case BSC.split '-' compiler of
+            ["ghc", version] -> Just version
+            _ -> Nothing
+        parseGhcVersion :: BSC.ByteString -> Maybe Version
+        parseGhcVersion version =
+          case filter ((== "") . snd) $
+               readP_to_S parseVersion $ BSC.unpack version of
+            [(ver, "")] -> Just ver
+            _ -> Nothing
+    case parseHeader header >>= parseCompiler >>= parseGhcVersion of
+      Just version -> return $ Right version
+      _ ->
+        return $
+        Left $
+        "Unexpected setup-config header: \"" ++
+        BSC.unpack header ++
+        "\"\nIt may mean that the version of Cabal used to build this package is not supported by haskell-code-indexer yet."
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,4,0)
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 6, 4, 0], versionTags = []}
+#elif MIN_VERSION_GLASGOW_HASKELL(8,6,3,0)     
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 6, 3, 0], versionTags = []}    
+#elif MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) 
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 4, 4, 0], versionTags = []}
+#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 4, 3, 0], versionTags = []}
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 2, 2, 0], versionTags = []}
+#else
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 0, 2, 0], versionTags = []}
+#endif  
+      
 buildDirectoryTree :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree
 buildDirectoryTree path ignoreDirectories isHaskellModule = do
   (_dir DT.:/ tree) <- DT.readDirectoryWith (const . return $ ()) path