{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Check
( GhcVersionChecker,
InstallationCheck(..),
PackageCheck,
PackageMismatch (..),
makeGhcVersionChecker,
checkGhcVersion,
)
where
import Control.Exception
import Control.Monad (unless, filterM)
import Data.Function (on)
import Data.List (intersectBy)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid (First (First), getFirst)
import Data.Version (Version)
import GHC (Ghc, getSessionDynFlags, runGhc, setSessionDynFlags)
import GHC.Check.Executable (getGhcVersion, guessExecutablePathFromLibdir)
import GHC.Check.PackageDb (PackageVersion (..), getPackageVersion, version)
import GHC.Check.Util (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 PackageCheck
}
| InstallationMismatch { libdir :: !String, compileTime, runTime :: !Version}
| InstallationNotFound { libdir :: !String }
type PackageCheck = Maybe (String, PackageMismatch)
data PackageMismatch
= VersionMismatch { compileTime, runTime :: !Version }
| AbiMismatch { compileTimeAbi, runTimeAbi :: !String }
deriving (Eq, Show)
comparePackageVersions :: PackageVersion -> PackageVersion -> Maybe PackageMismatch
comparePackageVersions compile run
| compile == run = Nothing
| version compile == version run =
Just $ AbiMismatch (abi compile) (abi run)
| otherwise =
Just $ VersionMismatch (version compile) (version run)
collectPackageVersions :: [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions =
fmap catMaybes . mapM (\p -> fmap (p,) <$> getPackageVersion p)
checkGhcVersion ::
[String] ->
[(String, PackageVersion)] ->
GhcVersionChecker
checkGhcVersion trackedPackages 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 $ do
runTimeVersions <- collectPackageVersions trackedPackages
let compares =
Map.intersectionWith
comparePackageVersions
compileTimeVersionsMap
(Map.fromList runTimeVersions)
mismatches = Map.mapMaybe id compares
return
$ getFirst
$ foldMap
(\p -> First $ (p,) <$> Map.lookup p mismatches)
trackedPackages
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 trackedPackages $$(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