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.5.0.3 +version: 0.5.0.4 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 @@ -32,8 +32,10 @@ process, safe-exceptions, template-haskell, + th-compat >= 0.1.2, transformers hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 if flag(ghc-check-use-package-abis) cpp-options: -DUSE_PACKAGE_ABIS diff --git a/src/GHC/Check.hs b/src/GHC/Check.hs --- a/src/GHC/Check.hs +++ b/src/GHC/Check.hs @@ -32,12 +32,13 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Version (Version) +import Data.Version (versionBranch, Version) import GHC (Ghc) 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 qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax.Compat (examineSplice, liftSplice, SpliceQ) import System.Directory (doesDirectoryExist, doesFileExist) #if USE_PACKAGE_ABIS @@ -82,6 +83,7 @@ -- ^ Same version and abi deriving (Eq, Show) +isPackageCheckFailure :: PackageCheck -> Bool isPackageCheckFailure VersionMatch {} = False isPackageCheckFailure _ = True @@ -101,6 +103,14 @@ fmap catMaybes . mapM (\p -> fmap (p,) <$> getPackageVersion p) -- | Checks if the run-time version of the @ghc@ package matches the given version. +-- +-- If the package database contains an unstable ghc library version, +-- we omit the package version check. +-- This leads to a more convenient usage for working on GHC. +-- When developing for or on GHC, you can compile GHC HEAD with a bootstrap compiler and +-- use the freshly compiled ghc library to load programs that use the latest GHC API. +-- We consider the ghc version to be unstable according to the +-- checkGhcVersion :: [(String, PackageVersion)] -> GhcVersionChecker @@ -123,15 +133,26 @@ $ do runTimeVersions <- collectPackageVersions (map fst compileTimeVersions) let compares = - Map.intersectionWith - comparePackageVersions - compileTimeVersionsMap - (Map.fromList runTimeVersions) + if isUnstableGhcVersion (lookup "ghc" runTimeVersions) + then Map.empty + else 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) + where + -- | The ghc library version is unstable, if it has + -- at least the form and 'y' is odd. + isUnstableGhcVersion :: Maybe PackageVersion -> Bool + isUnstableGhcVersion Nothing = False + isUnstableGhcVersion (Just ver) = + case versionBranch (version ver) of + (_: major: _minors) -> odd major + _ -> False -- | @makeGhcVersionChecker libdir@ returns a function to check the run-time -- version of GHC against the compile-time version. It performs two checks: @@ -152,13 +173,14 @@ -- > setupGhcApi -- > result <- packageCheck -- > case guessCompatibility result of ... -makeGhcVersionChecker :: IO FilePath -> TExpQ GhcVersionChecker -makeGhcVersionChecker getLibdir = do - compileTimeVersions <- runIO $ compileTimeVersions getLibdir - [||checkGhcVersion $$(liftTyped compileTimeVersions)||] +makeGhcVersionChecker :: IO FilePath -> SpliceQ GhcVersionChecker +makeGhcVersionChecker getLibdir = liftSplice $ do + compileTimeVersions <- TH.runIO $ getCompileTimeVersions getLibdir + examineSplice [||checkGhcVersion $$(liftTyped compileTimeVersions)||] -compileTimeVersions :: IO FilePath -> IO [(String, PackageVersion)] -compileTimeVersions getLibdir = do + +getCompileTimeVersions :: IO FilePath -> IO [(String, PackageVersion)] +getCompileTimeVersions getLibdir = do #if USE_PACKAGE_ABIS libdir <- getLibdir libdirExists <- doesDirectoryExist libdir 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,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} +{-# OPTIONS_GHC -Wall #-} -- | Discover the GHC version via the package database. Requirements: -- -- * the package database must be compatible, which is usually not the case @@ -15,11 +17,26 @@ import Control.Monad.Trans.Class as Monad (MonadTrans (lift)) import Data.String (IsString (fromString)) import Data.Version (Version) +import Language.Haskell.TH.Syntax (Lift) +import Data.Foldable (find) +import Control.Applicative (Alternative((<|>))) +#if MIN_VERSION_ghc(9,0,1) import GHC + (unitState, Ghc, + getSessionDynFlags, + ) +import GHC.Data.Maybe (MaybeT (MaybeT), runMaybeT) +import GHC.Unit.Info (PackageName (PackageName)) +import GHC.Unit.State + (lookupUnit, explicitUnits, lookupUnitId, + lookupPackageName, GenericUnitInfo (..), + UnitInfo, unitPackageNameString) +import GHC.Unit.Types (indefUnit) +#else +import GHC (pkgState, Ghc, getSessionDynFlags, ) -import GHC.Check.Util import Maybes (MaybeT (MaybeT), runMaybeT) import Module (componentIdToInstalledUnitId) import PackageConfig (PackageName (PackageName)) @@ -27,14 +44,14 @@ (lookupPackage, explicitPackages, lookupInstalledPackage, lookupPackageName ) -import Packages (InstalledPackageInfo (..)) +import Packages (InstalledPackageInfo (packageVersion, abiHash)) import Packages (PackageConfig) -import Language.Haskell.TH.Syntax (Lift) -import Data.Foldable (find) import Packages (packageNameString) -import Control.Applicative (Alternative((<|>))) +#endif import GHC.Stack (HasCallStack) +import GHC.Check.Util + data PackageVersion = PackageVersion { myVersion :: !MyVersion, @@ -45,10 +62,35 @@ version :: PackageVersion -> Version version PackageVersion{ myVersion = MyVersion v} = v +#if MIN_VERSION_ghc(9,0,1) -- | @getPackageVersion p@ returns the version of package @p@ that will be used in the Ghc session. getPackageVersion :: String -> Ghc (Maybe PackageVersion) getPackageVersion pName = runMaybeT $ do dflags <- Monad.lift getSessionDynFlags + let pkgst = unitState dflags + depends = explicitUnits pkgst + + let explicit = do + pkgs <- traverse (MaybeT . return . lookupUnit pkgst) depends + MaybeT $ return $ find (\p -> unitPackageNameString p == pName ) pkgs + + notExplicit = do + component <- MaybeT $ return $ lookupPackageName pkgst $ PackageName $ fromString pName + MaybeT $ return $ lookupUnitId pkgst (indefUnit component) + + p <- explicit <|> notExplicit + + return $ fromPackageConfig p + +fromPackageConfig :: UnitInfo -> PackageVersion +fromPackageConfig p = PackageVersion (MyVersion $ unitPackageVersion p) (Just $ unitAbiHash p) + +#else + +-- | @getPackageVersion p@ returns the version of package @p@ that will be used in the Ghc session. +getPackageVersion :: String -> Ghc (Maybe PackageVersion) +getPackageVersion pName = runMaybeT $ do + dflags <- Monad.lift getSessionDynFlags let pkgst = pkgState dflags depends = explicitPackages pkgst @@ -66,6 +108,7 @@ fromPackageConfig :: PackageConfig -> PackageVersion fromPackageConfig p = PackageVersion (MyVersion $ packageVersion p) (Just $ abiHash p) +#endif fromVersionString :: HasCallStack => String -> PackageVersion -fromVersionString v = PackageVersion (read v) Nothing +fromVersionString v = PackageVersion (MyVersion $ read v) Nothing 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 @@ -4,13 +4,15 @@ {-# LANGUAGE CPP, TemplateHaskell #-} module GHC.Check.Util (MyVersion(..), liftTyped, gcatchSafe) where -import Control.Exception.Safe +import Control.Exception.Safe as Safe import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Version ( Version, parseVersion ) -import GHC (Ghc, gcatch) +import GHC (Ghc) +import qualified GHC import GHC.Exts (IsList (fromList), toList) import Language.Haskell.TH ( TExpQ ) import Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH.Syntax.Compat import qualified Text.Read as Read -- | A wrapper around 'Version' with TH lifting @@ -20,26 +22,37 @@ instance Lift MyVersion where #if MIN_VERSION_template_haskell(2,16,0) liftTyped = liftMyVersion -#endif +#else lift = unTypeQ . liftMyVersion +#endif + -- lift = unTypeCode . liftMyVersion instance Read MyVersion where readPrec = Read.lift $ MyVersion <$> parseVersion +#if MIN_VERSION_template_haskell(2,17,0) +liftMyVersion :: (Quote m) => MyVersion -> Splice m MyVersion +#else liftMyVersion :: MyVersion -> TExpQ MyVersion -liftMyVersion ver = do - verLifted <- TH.lift (toList ver) - [|| fromList $$(pure $ TExp verLifted) ||] +#endif +liftMyVersion ver = liftSplice $ do + verLifted <- liftQuote (toList ver) + examineSplice [|| fromList $$( liftSplice . pure $ TExp verLifted)||] + #if !MIN_VERSION_template_haskell(2,16,0) liftTyped :: Lift a => a -> TExpQ a liftTyped = unsafeTExpCoerce . lift #endif gcatchSafe :: forall e a . Exception e => Ghc a -> (e -> Ghc a) -> Ghc a -gcatchSafe act h = act `gcatch` rethrowAsyncExceptions +#if MIN_VERSION_ghc(9,0,1) +gcatchSafe = Safe.catch +#else +gcatchSafe act h = act `GHC.gcatch` rethrowAsyncExceptions where rethrowAsyncExceptions :: e -> Ghc a rethrowAsyncExceptions e | isAsyncException e = liftIO . throwIO $ e | otherwise = h e +#endif