summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPepeIborra <>2021-04-06 22:36:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2021-04-06 22:36:00 (GMT)
commitd181b0b9dfd74f14a788239d6b5e21dd8dabc025 (patch)
tree7f0e1d65b0c72b9ca422896a305a6a270cf5bc6a
parentb46a4051f9ef8062a833b51bf8121c8a4fbbe462 (diff)
version 0.5.0.4HEAD0.5.0.4master
-rw-r--r--ghc-check.cabal4
-rw-r--r--src/GHC/Check.hs46
-rw-r--r--src/GHC/Check/PackageDb.hs55
-rw-r--r--src/GHC/Check/Util.hs27
4 files changed, 106 insertions, 26 deletions
diff --git a/ghc-check.cabal b/ghc-check.cabal
index 5f0cd2d..e7c53ee 100644
--- 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 @@ library
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
index e77b676..e8b77bf 100644
--- a/src/GHC/Check.hs
+++ b/src/GHC/Check.hs
@@ -32,12 +32,13 @@ 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.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 @@ data PackageCheck
-- ^ Same version and abi
deriving (Eq, Show)
+isPackageCheckFailure :: PackageCheck -> Bool
isPackageCheckFailure VersionMatch {} = False
isPackageCheckFailure _ = True
@@ -101,6 +103,14 @@ collectPackageVersions =
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
+-- <https://downloads.haskell.org/~ghc/8.10.1/docs/html/users_guide/intro.html#ghc-version-numbering-policy GHC User Guide>
checkGhcVersion ::
[(String, PackageVersion)] ->
GhcVersionChecker
@@ -123,15 +133,26 @@ checkGhcVersion compileTimeVersions runTimeLibdir = do
$ 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 <x.y> 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 @@ checkGhcVersion compileTimeVersions runTimeLibdir = do
-- > 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
index 258747d..f5ab282 100644
--- 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 @@ where
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 @@ import Packages
(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,6 +62,31 @@ data PackageVersion
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
@@ -66,6 +108,7 @@ getPackageVersion pName = runMaybeT $ do
fromPackageConfig :: PackageConfig -> PackageVersion
fromPackageConfig p = PackageVersion (MyVersion $ packageVersion p) (Just $ abiHash p)
+#endif
fromVersionString :: HasCallStack => String -> PackageVersion
-fromVersionString v = PackageVersion (read v) Nothing \ No newline at end of file
+fromVersionString v = PackageVersion (MyVersion $ read v) Nothing
diff --git a/src/GHC/Check/Util.hs b/src/GHC/Check/Util.hs
index 9f6eaaf..5b4f310 100644
--- 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,16 +22,23 @@ newtype MyVersion = MyVersion Version
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
@@ -37,9 +46,13 @@ 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