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.2.0.0 +version: 0.3.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 @@ -13,10 +13,15 @@ extra-source-files: README.md library - exposed-modules: GHC.Check, GHC.Check.Internal + exposed-modules: GHC.Check, + GHC.Check.Executable + GHC.Check.PackageDb + GHC.Check.Util build-depends: base >=4.10.0.0 && < 5.0, + filepath, ghc, ghc-paths, + process, template-haskell, transformers hs-source-dirs: src diff --git a/src/GHC/Check.hs b/src/GHC/Check.hs --- a/src/GHC/Check.hs +++ b/src/GHC/Check.hs @@ -1,37 +1,53 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module GHC.Check ( VersionCheck(..) -, checkGhcVersion -, compileTimeVersion -, ghcCompileTimeVersion -, runTimeVersion +, makeGhcVersionChecker ) where +import Control.Exception +import Data.Maybe import Data.Version (Version) import GHC -import GHC.Check.Internal - --- | Returns the compile-time version of the @ghc@ package. --- Uses 'guessLibdir' to find the GHC lib dir -ghcCompileTimeVersion :: Version -ghcCompileTimeVersion = $$(compileTimeVersion guessLibdir "ghc") - --- | Returns the run-time version of the @ghc@ package in the package database -runTimeVersion :: Ghc (Maybe Version) -runTimeVersion = getGhcVersion +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 data VersionCheck = Match - | Mismatch { compileTime :: Version - , runTime :: Maybe Version + | Mismatch { compileTime :: !Version + , runTime :: !Version } + | Failure String deriving (Eq, Show) --- | Checks if the run-time version of the @ghc@ package matches the compile-time version. --- To be able to specify a custom libdir, inline this logic in your program. -checkGhcVersion :: Ghc VersionCheck -checkGhcVersion = do - v <- getGhcVersion - return $ if v == Just ghcCompileTimeVersion - then GHC.Check.Match - else Mismatch ghcCompileTimeVersion v +-- | A GHC version retrieved from the ghc executable +ghcRunTimeVersion :: IO Version +ghcRunTimeVersion = do + libdir <- guessLibdir + getGhcVersion (guessExecutablePathFromLibdir libdir) + +-- | 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) + ] + +-- | @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) +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) ||] diff --git a/src/GHC/Check/Executable.hs b/src/GHC/Check/Executable.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Check/Executable.hs @@ -0,0 +1,27 @@ +{- | Discover the GHC version by querying the GHC executable + + -} +module GHC.Check.Executable where + +import Data.Version +import GHC.Check.Util +import System.FilePath +import System.Process +import Text.ParserCombinators.ReadP +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + +-- | Takes a path to the GHC binary to query. +-- Throws if anything goes wrong. +getGhcVersion :: FilePath -> IO Version +getGhcVersion fp = do + out <- readProcess fp ["--numeric-version"] "" + case readP_to_S (parseVersion <* eof) (trim out) of + [(v, "")] -> return v + _ -> error $ "Failed to parse GHC version: " <> out + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +guessExecutablePathFromLibdir :: FilePath -> FilePath +guessExecutablePathFromLibdir fp = fp "bin" "ghc" diff --git a/src/GHC/Check/Internal.hs b/src/GHC/Check/Internal.hs deleted file mode 100644 --- a/src/GHC/Check/Internal.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module GHC.Check.Internal where - -import Control.Monad.Trans.Class as Monad (MonadTrans (lift)) -import Data.Maybe (fromMaybe) -import Data.String (IsString (fromString)) -import Data.Version (Version) -import GHC -import GHC.Exts (IsList (fromList), toList) -import qualified GHC.Paths -import Language.Haskell.TH -import Language.Haskell.TH.Syntax as TH (TExp(TExp), lift) -import Maybes (MaybeT (MaybeT), runMaybeT) -import Module (componentIdToInstalledUnitId) -import PackageConfig (PackageName (PackageName)) -import Packages (lookupInstalledPackage, lookupPackageName) -import Packages (InstalledPackageInfo (packageVersion)) -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" - --- | @getPackageVersion p@ returns the version of package @p@ in --- the package database -getPackageVersion :: String -> Ghc (Maybe Version) -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 - --- | Returns the version of the @ghc@ package in the environment package database -getGhcVersion :: Ghc (Maybe Version) -getGhcVersion = getPackageVersion "ghc" - --- | @getPackageVersionIO ghc-libdir p@ returns the version of package @p@ --- in the default package database -getPackageVersionIO :: FilePath -> String -> IO 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 - - ver <- getPackageVersion package - case ver of - Just v -> - return v - Nothing -> - error $ "Cannot find " <> package <> " in the package database at " <> libdir - --- | @compileTimeVersion get-libdir p@ returns the version of package @p@ in --- the compile-time package database. -compileTimeVersion :: IO FilePath -> String -> TExpQ Version -compileTimeVersion getLibdir package = do - ver <- runIO $ do - libdir <- getLibdir - v <- getPackageVersionIO libdir package - return (toList v) - verLifted <- TH.lift (toList ver) - [|| fromList $$(pure $ TExp verLifted) ||] diff --git a/src/GHC/Check/PackageDb.hs b/src/GHC/Check/PackageDb.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Check/PackageDb.hs @@ -0,0 +1,41 @@ + +{- | 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 where + +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)) + +-- | @getPackageVersion p@ returns the version of package @p@ in +-- the package database +getPackageVersion :: String -> Ghc (Maybe Version) +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 + + getPackageVersion package diff --git a/src/GHC/Check/Util.hs b/src/GHC/Check/Util.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Check/Util.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} +module GHC.Check.Util where + + +import Data.Maybe +import Data.Version +import GHC.Exts (IsList (fromList), toList) +import qualified GHC.Paths +import Language.Haskell.TH +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" + +liftVersion :: Version -> TExpQ Version +liftVersion ver = do + verLifted <- TH.lift (toList ver) + [|| fromList $$(pure $ TExp verLifted) ||]