diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ # ghc-check +[![GitHub CI](https://github.com/pepeiborra/ghc-check/workflows/CI/badge.svg)](https://github.com/pepeiborra/ghc-check/actions) + Use Template Haskell to record the ghc api version at compile time and detect mismatches with the run time version. diff --git a/ghc-check.cabal b/ghc-check.cabal --- a/ghc-check.cabal +++ b/ghc-check.cabal @@ -1,7 +1,7 @@ cabal-version: 1.20 build-type: Simple name: ghc-check -version: 0.3.0.1 +version: 0.4.0.0 synopsis: detect mismatches between compile-time and run-time versions of the ghc api description: detect mismatches between compile-time and run-time versions of the ghc api bug-reports: https://github.com/pepeiborra/ghc-check/issues @@ -19,6 +19,8 @@ other-modules: GHC.Check.Util build-depends: base >=4.10.0.0 && < 5.0, + containers, + directory, filepath, ghc, ghc-paths, diff --git a/src/GHC/Check.hs b/src/GHC/Check.hs --- a/src/GHC/Check.hs +++ b/src/GHC/Check.hs @@ -1,54 +1,153 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} + module GHC.Check -( VersionCheck(..) -, makeGhcVersionChecker -, checkGhcVersion -) where + ( GhcVersionChecker, + InstallationCheck(..), + PackageCheck, + PackageMismatch (..), + makeGhcVersionChecker, + checkGhcVersion, + ) +where -import Control.Exception -import Data.Maybe -import Data.Version (Version) -import GHC -import GHC.Check.Executable (getGhcVersion, guessExecutablePathFromLibdir) -import GHC.Check.PackageDb (getPackageVersionIO) -import GHC.Check.Util (liftVersion, guessLibdir) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax +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) -data VersionCheck - = Match - | Mismatch { compileTime :: !Version - , runTime :: !Version - } - | Failure String - deriving (Eq, Show) +-- | Given a run-time libdir, checks the ghc installation and returns +-- a 'Ghc' action to check the package database +type GhcVersionChecker = String -> IO InstallationCheck --- | A GHC version retrieved from the ghc executable -ghcRunTimeVersion :: IO Version -ghcRunTimeVersion = do - libdir <- guessLibdir - getGhcVersion (guessExecutablePathFromLibdir libdir) +data InstallationCheck + = InstallationChecked + { compileTime :: !Version + -- ^ The compile time version of ghc + , packageCheck :: Ghc PackageCheck + -- ^ The second stage of the ghc version check + } + -- ^ The ghc installation looks fine. Further checks are needed for the package libraries. + | InstallationMismatch { libdir :: !String, compileTime, runTime :: !Version} + -- ^ The libdir points to a different ghc version + | InstallationNotFound { libdir :: !String } + -- ^ The libdir does not exist +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) + -- | Checks if the run-time version of the @ghc@ package matches the given version. -checkGhcVersion :: Version -> IO VersionCheck -checkGhcVersion expectedVersion = handleErrors $ do - v <- ghcRunTimeVersion - return $ if v == expectedVersion - then GHC.Check.Match - else Mismatch expectedVersion v - where - handleErrors = flip catches - [Handler (throwIO @SomeAsyncException) - ,Handler (pure . Failure . show @SomeException) - ] +checkGhcVersion :: + [String] -> + [(String, PackageVersion)] -> + GhcVersionChecker +checkGhcVersion trackedPackages compileTimeVersions runTimeLibdir = do + let compileTimeVersionsMap = Map.fromList compileTimeVersions + compileTime = version $ compileTimeVersionsMap Map.! "ghc" --- | @makeGhcVersionChecker libdir@ returns a computation to check the run-time --- version of ghc against the compile-time version. -makeGhcVersionChecker :: IO (Maybe FilePath) -> TExpQ (IO VersionCheck) + 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 libdir@ returns a function to check the run-time +-- version of ghc against the compile-time version. It performs two checks: +-- +-- 1. It checks the version of the ghc installation given the run-time libdir +-- In some platforms, like Nix, the libdir is not fixed at compile-time +-- +-- 2. It compares the version of the 'ghc' package, if found at run-time. +-- If not, it compares the 'abi' of the 'base' package. +-- +-- > ghcChecker :: IO(Ghc (String -> PackageCheck)) +-- > ghcChecker = $$(makeGhcVersionChecker (pure $ Just GHC.Paths.libdir)) +-- > +-- > checkGhcVersion :: IO () +-- > checkGhcVersion = do +-- > InstallationChecked ghcLibVersionChecker <- ghcChecker runTimeLibdir +-- > res <- runGhc (Just runTimeLibdir) $ do +-- > setupGhcApi +-- > Right Nothing <- gtry ghcLibVersionChecker +-- > doSomethingInteresting + +makeGhcVersionChecker :: IO FilePath -> TExpQ GhcVersionChecker makeGhcVersionChecker getLibdir = do - compileTimeVersion <- runIO $ do - libdir <- maybe guessLibdir return =<< getLibdir - mbVersion <- getPackageVersionIO libdir "ghc" - return $ fromMaybe (error "unreachable - the ghc package is a Cabal dependency") mbVersion - [|| checkGhcVersion $$(liftVersion compileTimeVersion) ||] + 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 + -- initialize the Ghc session + -- there's probably a better way to do this. + dflags <- getSessionDynFlags + _ <- setSessionDynFlags dflags + action + +-- | A GHC version retrieved from the ghc installation in the given libdir +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 diff --git a/src/GHC/Check/Executable.hs b/src/GHC/Check/Executable.hs --- a/src/GHC/Check/Executable.hs +++ b/src/GHC/Check/Executable.hs @@ -10,7 +10,10 @@ import Text.ParserCombinators.ReadP import Data.Char (isSpace) import Data.List (dropWhileEnd) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + -- | Takes a path to the GHC binary to query. -- Throws if anything goes wrong. getGhcVersion :: FilePath -> IO Version @@ -23,5 +26,9 @@ trim :: String -> String trim = dropWhileEnd isSpace . dropWhile isSpace -guessExecutablePathFromLibdir :: FilePath -> FilePath -guessExecutablePathFromLibdir fp = fp "bin" "ghc" +-- | Returns a list of possible paths for the GHC executable +guessExecutablePathFromLibdir :: FilePath -> NonEmpty FilePath +guessExecutablePathFromLibdir fp = NonEmpty.fromList + [ fp "bin" "ghc" -- Linux + , fp ".." "bin" "ghc.exe" -- Windows + ] diff --git a/src/GHC/Check/PackageDb.hs b/src/GHC/Check/PackageDb.hs --- a/src/GHC/Check/PackageDb.hs +++ b/src/GHC/Check/PackageDb.hs @@ -1,41 +1,57 @@ - -{- | Discover the GHC version via the package database. Requirements: +{-# LANGUAGE DeriveLift #-} +-- | Discover the GHC version via the package database. Requirements: +-- +-- * the package database must be compatible, which is usually not the case +-- across major ghc versions. +-- +-- * the 'ghc' package is registered, which is not always the case. +module GHC.Check.PackageDb + ( PackageVersion(abi), version, + getPackageVersion, + ) +where - * the package database must be compatible, which is usually not the case - across major ghc versions. +import Control.Monad.Trans.Class as Monad (MonadTrans (lift)) +import Data.Maybe (fromMaybe) +import Data.String (IsString (fromString)) +import Data.Version (Version) +import GHC + ( Ghc, + getSessionDynFlags, + runGhc, + setSessionDynFlags, + ) +import GHC.Check.Util +import GHC.Exts (IsList (fromList), toList) +import Maybes (MaybeT (MaybeT), runMaybeT) +import Module (componentIdToInstalledUnitId) +import PackageConfig (PackageName (PackageName)) +import Packages + ( lookupInstalledPackage, + lookupPackageName, + ) +import Packages (InstalledPackageInfo (..)) +import Packages (PackageConfig) +import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH (TExpQ) - * the 'ghc' package is registered, which is not always the case. - -} -module GHC.Check.PackageDb where +data PackageVersion + = PackageVersion + { myVersion :: !MyVersion, + abi :: !String + } + deriving (Eq, Lift, Show) -import Control.Monad.Trans.Class as Monad (MonadTrans (lift)) -import Data.Maybe (fromMaybe) -import Data.String (IsString (fromString)) -import Data.Version (Version) -import GHC (setSessionDynFlags, runGhc, getSessionDynFlags, Ghc) -import GHC.Exts (IsList (fromList), toList) -import Maybes (MaybeT (MaybeT), runMaybeT) -import Module (componentIdToInstalledUnitId) -import PackageConfig (PackageName (PackageName)) -import Packages (lookupInstalledPackage, lookupPackageName) -import Packages (InstalledPackageInfo (packageVersion)) +version :: PackageVersion -> Version +version PackageVersion{ myVersion = MyVersion v} = v --- | @getPackageVersion p@ returns the version of package @p@ in --- the package database -getPackageVersion :: String -> Ghc (Maybe Version) +-- | @getPackageVersion p@ returns the version of package @p@ in the package database +getPackageVersion :: String -> Ghc (Maybe PackageVersion) getPackageVersion packageName = runMaybeT $ do - dflags <- Monad.lift getSessionDynFlags - component <- MaybeT $ return $ lookupPackageName dflags $ PackageName $ fromString packageName - p <- MaybeT $ return $ lookupInstalledPackage dflags (componentIdToInstalledUnitId component) - return $ packageVersion p - --- | @getPackageVersionIO ghc-libdir p@ returns the version of package @p@ --- in the default package database -getPackageVersionIO :: FilePath -> String -> IO (Maybe Version) -getPackageVersionIO libdir package = runGhc (Just libdir) $ do - -- initialize the Ghc session - -- there's probably a beteter way to do this. - dflags <- getSessionDynFlags - _ <- setSessionDynFlags dflags + dflags <- Monad.lift getSessionDynFlags + component <- MaybeT $ return $ lookupPackageName dflags $ PackageName $ fromString packageName + p <- MaybeT $ return $ lookupInstalledPackage dflags (componentIdToInstalledUnitId component) + return $ mkPackageVersion p - getPackageVersion package +mkPackageVersion :: PackageConfig -> PackageVersion +mkPackageVersion p = PackageVersion (MyVersion $ packageVersion p) (abiHash p) diff --git a/src/GHC/Check/Util.hs b/src/GHC/Check/Util.hs --- a/src/GHC/Check/Util.hs +++ b/src/GHC/Check/Util.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TemplateHaskell #-} -module GHC.Check.Util where - +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, TemplateHaskell #-} +module GHC.Check.Util (MyVersion(..), liftTyped) where import Data.Maybe import Data.Version @@ -10,11 +11,22 @@ import Language.Haskell.TH.Syntax as TH import System.Environment (lookupEnv) --- | Look up the GHC lib dir in the NIX environment, then in the 'GHC.Paths' -guessLibdir :: IO FilePath -guessLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" +-- | A wrapper around 'Version' with TH lifting +newtype MyVersion = MyVersion Version + deriving (Eq, IsList, Show) -liftVersion :: Version -> TExpQ Version -liftVersion ver = do +instance Lift MyVersion where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftMyVersion +#endif + lift = unTypeQ . liftMyVersion + +liftMyVersion :: MyVersion -> TExpQ MyVersion +liftMyVersion ver = do verLifted <- TH.lift (toList ver) [|| fromList $$(pure $ TExp verLifted) ||] + +#if !MIN_VERSION_template_haskell(2,16,0) +liftTyped :: Lift a => a -> TExpQ a +liftTyped = unsafeTExpCoerce . lift +#endif