{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Check
(
makeGhcVersionChecker,
GhcVersionChecker,
InstallationCheck (..),
PackageCheckResult (..),
PackageCheck (..),
guessCompatibility,
CompatibilityGuess (..),
NotCompatibleReason(..),
checkGhcVersion,
)
where
import Control.Applicative (Alternative ((<|>)))
import Control.Exception
import Control.Monad (filterM, unless)
import Data.Function (on)
import Data.List (find, intersectBy)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid (First (First), getFirst)
import Data.Version (Version, showVersion)
import GHC (Ghc, getSessionDynFlags, runGhc, setSessionDynFlags)
import GHC.Check.Executable (getGhcVersion, guessExecutablePathFromLibdir)
import GHC.Check.PackageDb (PackageVersion (..), getPackageVersion, version)
import GHC.Check.Util (gcatchSafe, liftTyped)
import Language.Haskell.TH (TExpQ, runIO)
import Language.Haskell.TH.Syntax (Lift (lift))
import System.Directory (doesDirectoryExist, doesFileExist)
type GhcVersionChecker = String -> IO InstallationCheck
data InstallationCheck
=
InstallationChecked
{
compileTime :: !Version,
packageCheck :: Ghc PackageCheckResult
}
|
InstallationMismatch {libdir :: !String, compileTime, runTime :: !Version}
|
InstallationNotFound {libdir :: !String}
data PackageCheckResult
=
PackageCheckSuccess !(NonEmpty (String, PackageCheck))
|
PackageCheckFailure !(NonEmpty (String, PackageCheck))
|
PackageCheckInconclusive ![String]
| PackageCheckError !SomeException
data PackageCheck
= VersionMismatch {compileTime, runTime :: !Version}
| AbiMismatch {compileTimeAbi, runTimeAbi :: !String, compileTime :: !Version}
| VersionMatch {packageVersion :: !PackageVersion}
deriving (Eq, Show)
isPackageCheckFailure VersionMatch {} = False
isPackageCheckFailure _ = True
comparePackageVersions :: PackageVersion -> PackageVersion -> PackageCheck
comparePackageVersions compile run
| compile == run = VersionMatch compile
| version compile == version run =
AbiMismatch (abi compile) (abi run) (version compile)
| otherwise =
VersionMismatch (version compile) (version run)
collectPackageVersions :: [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions =
fmap catMaybes . mapM (\p -> fmap (p,) <$> getPackageVersion p)
checkGhcVersion ::
[(String, PackageVersion)] ->
GhcVersionChecker
checkGhcVersion compileTimeVersions runTimeLibdir = do
let compileTimeVersionsMap = Map.fromList compileTimeVersions
compileTime = version $ compileTimeVersionsMap Map.! "ghc"
exists <- doesDirectoryExist runTimeLibdir
if not exists
then return $ InstallationNotFound runTimeLibdir
else do
runTime <- ghcRunTimeVersion runTimeLibdir
return $
if runTime /= compileTime
then InstallationMismatch {libdir = runTimeLibdir, ..}
else InstallationChecked compileTime
$ flip gcatchSafe (pure . PackageCheckError)
$ do
runTimeVersions <- collectPackageVersions (map fst compileTimeVersions)
let compares =
Map.intersectionWith
comparePackageVersions
compileTimeVersionsMap
(Map.fromList runTimeVersions)
failure = PackageCheckFailure <$> nonEmpty (Map.toList $ Map.filter isPackageCheckFailure compares)
success = PackageCheckSuccess <$> nonEmpty (Map.toList compares)
inconclusive = PackageCheckInconclusive (map fst compileTimeVersions)
return $ fromMaybe inconclusive (failure <|> success)
makeGhcVersionChecker :: IO FilePath -> TExpQ GhcVersionChecker
makeGhcVersionChecker getLibdir = do
libdir <- runIO getLibdir
libdirExists <- runIO $ doesDirectoryExist libdir
unless libdirExists
$ error
$ "I could not find a GHC installation at " <> libdir
<> ". Please do a clean rebuild and/or reinstall GHC."
compileTimeVersions <-
runIO
$ runGhcPkg libdir
$ collectPackageVersions trackedPackages
[||checkGhcVersion $$(liftTyped compileTimeVersions)||]
where
trackedPackages = ["ghc", "base"]
runGhcPkg :: FilePath -> Ghc a -> IO a
runGhcPkg libdir action = runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags
action
ghcRunTimeVersion :: String -> IO Version
ghcRunTimeVersion libdir = do
let guesses = guessExecutablePathFromLibdir libdir
validGuesses <- filterM doesFileExist $ NonEmpty.toList guesses
case validGuesses of
firstGuess : _ -> getGhcVersion firstGuess
[] -> fail $ "Unable to find the GHC executable for libdir: " <> libdir
data CompatibilityGuess
= ProbablyCompatible {warning :: Maybe String}
| NotCompatible {reason :: !NotCompatibleReason}
deriving Eq
data NotCompatibleReason
= PackageVersionMismatch
{ compileTime :: !Version,
runTime :: !Version,
packageName :: !String
}
| BasePackageAbiMismatch
{ compileTimeAbi :: !String,
runTimeAbi :: !String,
compileTime :: !Version
}
deriving Eq
guessCompatibility :: PackageCheckResult -> CompatibilityGuess
guessCompatibility result = case result of
PackageCheckFailure evidence
| Just problem <- findInterestingProblem evidence -> do
case problem of
(packageName, VersionMismatch {..}) ->
NotCompatible PackageVersionMismatch {..}
("base", AbiMismatch {..}) ->
NotCompatible BasePackageAbiMismatch {..}
(_, VersionMatch {}) ->
ProbablyCompatible Nothing
| otherwise ->
ProbablyCompatible Nothing
PackageCheckInconclusive attempts ->
ProbablyCompatible $ Just $
"unable to validate GHC version. Could not find any run-time packages to test: "
<> show attempts
PackageCheckError err ->
ProbablyCompatible $ Just $ "Warning: unable to validate GHC version: " <> show err
PackageCheckSuccess !_evidence ->
ProbablyCompatible Nothing
findInterestingProblem :: NonEmpty (String, PackageCheck) -> Maybe (String, PackageCheck)
findInterestingProblem evidence = find isInterestingProblem evidence
where
ghcVersionMatches = any isGhcVersionMatchEvidence evidence
isInterestingProblem (_, VersionMismatch {}) = True
isInterestingProblem (_, AbiMismatch {}) =
not ghcVersionMatches
isInterestingProblem _ = False
isGhcVersionMatchEvidence ("ghc", VersionMatch {}) = True
isGhcVersionMatchEvidence ("ghc", AbiMismatch {}) =
True
isGhcVersionMatchEvidence _ = False