version 0.5.0.4HEAD0.5.0.4master

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