ghc-check 0.3.0.1 → 0.4.0.0

raw patch · 6 files changed

+228/−90 lines, 6 filesdep +containersdep +directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, directory

API changes (from Hackage documentation)

Files

• README.md +2/−0
• ghc-check.cabal +3/−1
• src/GHC/Check.hs +143/−44
• src/GHC/Check/Executable.hs +9/−2
• src/GHC/Check/PackageDb.hs +51/−35
• src/GHC/Check/Util.hs +20/−8

@@ -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.

@@ -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,

@@ -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

@@ -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+    ]

@@ -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)

@@ -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