{-# LANGUAGE CPP          #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module GHC.Check
  ( -- * GHC version check
    makeGhcVersionChecker,
    GhcVersionChecker,
    InstallationCheck (..),
    PackageCheckResult (..),
    PackageCheck (..),

    -- ** Interpreting the results
    guessCompatibility,
    CompatibilityGuess (..),
    NotCompatibleReason(..),

    -- ** Exports for TH
    checkGhcVersion,
  )
where

import Control.Applicative (Alternative ((<|>)))
import Control.Exception
import Control.Monad (filterM, unless)
import Data.List (find)
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 (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 qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax.Compat (examineSplice, liftSplice, SpliceQ)
import System.Directory (doesDirectoryExist, doesFileExist)

#if USE_PACKAGE_ABIS
import GHC (getSessionDynFlags, runGhc, setSessionDynFlags)
#else
import GHC.Check.PackageDb (fromVersionString)
#endif

-- | Given a run-time libdir, checks the ghc installation and returns
--   a 'Ghc' action to check the package database
type GhcVersionChecker = String -> IO InstallationCheck

data InstallationCheck
  = -- | The GHC installation looks fine. Further checks are needed for the package libraries.
    InstallationChecked
      { -- | The compile time version of GHC
        InstallationCheck -> Version
compileTime :: !Version,
        -- | The second stage of the GHC version check
        InstallationCheck -> Ghc PackageCheckResult
packageCheck :: Ghc PackageCheckResult
      }
  | -- | The libdir points to a different GHC version
    InstallationMismatch {InstallationCheck -> String
libdir :: !String, compileTime, InstallationCheck -> Version
runTime :: !Version}
  | -- | The libdir does not exist
    InstallationNotFound {libdir :: !String}

data PackageCheckResult
  = -- | All the compile time packages tested match
    PackageCheckSuccess !(NonEmpty (String, PackageCheck))
  | -- | Found package mismatches
    PackageCheckFailure !(NonEmpty (String, PackageCheck))
  | -- | None of the compile time packages could be found
    PackageCheckInconclusive ![String]
    -- | An exception arised during the package check
  | PackageCheckError !SomeException

data PackageCheck
  = VersionMismatch {PackageCheck -> Version
compileTime, PackageCheck -> Version
runTime :: !Version}
    -- ^ Different versions
  | AbiMismatch {PackageCheck -> String
compileTimeAbi, PackageCheck -> String
runTimeAbi :: !String, compileTime :: !Version}
    -- ^ Same version but different abi
  | VersionMatch {PackageCheck -> PackageVersion
packageVersion :: !PackageVersion}
    -- ^ Same version and abi
  deriving (PackageCheck -> PackageCheck -> Bool
(PackageCheck -> PackageCheck -> Bool)
-> (PackageCheck -> PackageCheck -> Bool) -> Eq PackageCheck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageCheck -> PackageCheck -> Bool
$c/= :: PackageCheck -> PackageCheck -> Bool
== :: PackageCheck -> PackageCheck -> Bool
$c== :: PackageCheck -> PackageCheck -> Bool
Eq, Int -> PackageCheck -> ShowS
[PackageCheck] -> ShowS
PackageCheck -> String
(Int -> PackageCheck -> ShowS)
-> (PackageCheck -> String)
-> ([PackageCheck] -> ShowS)
-> Show PackageCheck
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageCheck] -> ShowS
$cshowList :: [PackageCheck] -> ShowS
show :: PackageCheck -> String
$cshow :: PackageCheck -> String
showsPrec :: Int -> PackageCheck -> ShowS
$cshowsPrec :: Int -> PackageCheck -> ShowS
Show)

isPackageCheckFailure :: PackageCheck -> Bool
isPackageCheckFailure :: PackageCheck -> Bool
isPackageCheckFailure VersionMatch {} = Bool
False
isPackageCheckFailure PackageCheck
_ = Bool
True

comparePackageVersions :: PackageVersion -> PackageVersion -> PackageCheck
comparePackageVersions :: PackageVersion -> PackageVersion -> PackageCheck
comparePackageVersions PackageVersion
compile PackageVersion
run
  | PackageVersion -> Version
version PackageVersion
compile Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageVersion -> Version
version PackageVersion
run =
    Version -> Version -> PackageCheck
VersionMismatch (PackageVersion -> Version
version PackageVersion
compile) (PackageVersion -> Version
version PackageVersion
run)
  | Just String
abiCompile <- PackageVersion -> Maybe String
abi PackageVersion
compile
  , Just String
abiRun <- PackageVersion -> Maybe String
abi PackageVersion
run
  , String
abiCompile String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
abiRun
  = String -> String -> Version -> PackageCheck
AbiMismatch String
abiCompile String
abiRun (PackageVersion -> Version
version PackageVersion
compile)
  | Bool
otherwise
  = PackageVersion -> PackageCheck
VersionMatch PackageVersion
compile

collectPackageVersions :: [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions :: [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions =
  ([Maybe (String, PackageVersion)] -> [(String, PackageVersion)])
-> Ghc [Maybe (String, PackageVersion)]
-> Ghc [(String, PackageVersion)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (String, PackageVersion)] -> [(String, PackageVersion)]
forall a. [Maybe a] -> [a]
catMaybes (Ghc [Maybe (String, PackageVersion)]
 -> Ghc [(String, PackageVersion)])
-> ([String] -> Ghc [Maybe (String, PackageVersion)])
-> [String]
-> Ghc [(String, PackageVersion)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Ghc (Maybe (String, PackageVersion)))
-> [String] -> Ghc [Maybe (String, PackageVersion)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
p -> (PackageVersion -> (String, PackageVersion))
-> Maybe PackageVersion -> Maybe (String, PackageVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
p,) (Maybe PackageVersion -> Maybe (String, PackageVersion))
-> Ghc (Maybe PackageVersion)
-> Ghc (Maybe (String, PackageVersion))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc (Maybe PackageVersion)
getPackageVersion String
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
checkGhcVersion :: [(String, PackageVersion)] -> GhcVersionChecker
checkGhcVersion [(String, PackageVersion)]
compileTimeVersions String
runTimeLibdir = do
  let compileTimeVersionsMap :: Map String PackageVersion
compileTimeVersionsMap = [(String, PackageVersion)] -> Map String PackageVersion
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, PackageVersion)]
compileTimeVersions
      compileTime :: Version
compileTime = PackageVersion -> Version
version (PackageVersion -> Version) -> PackageVersion -> Version
forall a b. (a -> b) -> a -> b
$ Map String PackageVersion
compileTimeVersionsMap Map String PackageVersion -> String -> PackageVersion
forall k a. Ord k => Map k a -> k -> a
Map.! String
"ghc"

  Bool
exists <- String -> IO Bool
doesDirectoryExist String
runTimeLibdir

  if Bool -> Bool
not Bool
exists
    then InstallationCheck -> IO InstallationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallationCheck -> IO InstallationCheck)
-> InstallationCheck -> IO InstallationCheck
forall a b. (a -> b) -> a -> b
$ String -> InstallationCheck
InstallationNotFound String
runTimeLibdir
    else do
      Version
runTime <- String -> IO Version
ghcRunTimeVersion String
runTimeLibdir

      InstallationCheck -> IO InstallationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallationCheck -> IO InstallationCheck)
-> InstallationCheck -> IO InstallationCheck
forall a b. (a -> b) -> a -> b
$
        if Version
runTime Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
compileTime
          then InstallationMismatch :: String -> Version -> Version -> InstallationCheck
InstallationMismatch {$sel:libdir:InstallationChecked :: String
libdir = String
runTimeLibdir, Version
runTime :: Version
compileTime :: Version
$sel:runTime:InstallationChecked :: Version
$sel:compileTime:InstallationChecked :: Version
..}
          else Version -> Ghc PackageCheckResult -> InstallationCheck
InstallationChecked Version
compileTime
            (Ghc PackageCheckResult -> InstallationCheck)
-> Ghc PackageCheckResult -> InstallationCheck
forall a b. (a -> b) -> a -> b
$ (Ghc PackageCheckResult
 -> (SomeException -> Ghc PackageCheckResult)
 -> Ghc PackageCheckResult)
-> (SomeException -> Ghc PackageCheckResult)
-> Ghc PackageCheckResult
-> Ghc PackageCheckResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ghc PackageCheckResult
-> (SomeException -> Ghc PackageCheckResult)
-> Ghc PackageCheckResult
forall e a. Exception e => Ghc a -> (e -> Ghc a) -> Ghc a
gcatchSafe (PackageCheckResult -> Ghc PackageCheckResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageCheckResult -> Ghc PackageCheckResult)
-> (SomeException -> PackageCheckResult)
-> SomeException
-> Ghc PackageCheckResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> PackageCheckResult
PackageCheckError)
            (Ghc PackageCheckResult -> Ghc PackageCheckResult)
-> Ghc PackageCheckResult -> Ghc PackageCheckResult
forall a b. (a -> b) -> a -> b
$ do
              [(String, PackageVersion)]
runTimeVersions <- [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions (((String, PackageVersion) -> String)
-> [(String, PackageVersion)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, PackageVersion) -> String
forall a b. (a, b) -> a
fst [(String, PackageVersion)]
compileTimeVersions)
              let compares :: Map String PackageCheck
compares =
                    if Maybe PackageVersion -> Bool
isUnstableGhcVersion (String -> [(String, PackageVersion)] -> Maybe PackageVersion
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ghc" [(String, PackageVersion)]
runTimeVersions)
                      then Map String PackageCheck
forall k a. Map k a
Map.empty
                      else (PackageVersion -> PackageVersion -> PackageCheck)
-> Map String PackageVersion
-> Map String PackageVersion
-> Map String PackageCheck
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith
                            PackageVersion -> PackageVersion -> PackageCheck
comparePackageVersions
                            Map String PackageVersion
compileTimeVersionsMap
                            ([(String, PackageVersion)] -> Map String PackageVersion
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, PackageVersion)]
runTimeVersions)
                  failure :: Maybe PackageCheckResult
failure = NonEmpty (String, PackageCheck) -> PackageCheckResult
PackageCheckFailure (NonEmpty (String, PackageCheck) -> PackageCheckResult)
-> Maybe (NonEmpty (String, PackageCheck))
-> Maybe PackageCheckResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, PackageCheck)] -> Maybe (NonEmpty (String, PackageCheck))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Map String PackageCheck -> [(String, PackageCheck)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String PackageCheck -> [(String, PackageCheck)])
-> Map String PackageCheck -> [(String, PackageCheck)]
forall a b. (a -> b) -> a -> b
$ (PackageCheck -> Bool)
-> Map String PackageCheck -> Map String PackageCheck
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter PackageCheck -> Bool
isPackageCheckFailure Map String PackageCheck
compares)
                  success :: Maybe PackageCheckResult
success = NonEmpty (String, PackageCheck) -> PackageCheckResult
PackageCheckSuccess (NonEmpty (String, PackageCheck) -> PackageCheckResult)
-> Maybe (NonEmpty (String, PackageCheck))
-> Maybe PackageCheckResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, PackageCheck)] -> Maybe (NonEmpty (String, PackageCheck))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Map String PackageCheck -> [(String, PackageCheck)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String PackageCheck
compares)
                  inconclusive :: PackageCheckResult
inconclusive = [String] -> PackageCheckResult
PackageCheckInconclusive (((String, PackageVersion) -> String)
-> [(String, PackageVersion)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, PackageVersion) -> String
forall a b. (a, b) -> a
fst [(String, PackageVersion)]
compileTimeVersions)

              PackageCheckResult -> Ghc PackageCheckResult
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageCheckResult -> Ghc PackageCheckResult)
-> PackageCheckResult -> Ghc PackageCheckResult
forall a b. (a -> b) -> a -> b
$ PackageCheckResult
-> Maybe PackageCheckResult -> PackageCheckResult
forall a. a -> Maybe a -> a
fromMaybe PackageCheckResult
inconclusive (Maybe PackageCheckResult
failure Maybe PackageCheckResult
-> Maybe PackageCheckResult -> Maybe PackageCheckResult
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PackageCheckResult
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 :: Maybe PackageVersion -> Bool
isUnstableGhcVersion Maybe PackageVersion
Nothing = Bool
False
    isUnstableGhcVersion (Just PackageVersion
ver) =
      case Version -> [Int]
versionBranch (PackageVersion -> Version
version PackageVersion
ver) of
        (Int
_: Int
major: [Int]
_minors) -> Int -> Bool
forall a. Integral a => a -> Bool
odd Int
major
        [Int]
_ -> Bool
False

-- | @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 packageCheck <- ghcChecker runTimeLibdir
--    >     res <- runGhc (Just runTimeLibdir) $ do
--    >              setupGhcApi
--    >              result <- packageCheck
--    >              case guessCompatibility result of ...
makeGhcVersionChecker :: IO FilePath -> SpliceQ GhcVersionChecker
makeGhcVersionChecker :: IO String -> SpliceQ GhcVersionChecker
makeGhcVersionChecker IO String
getLibdir = SpliceQ GhcVersionChecker -> SpliceQ GhcVersionChecker
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (SpliceQ GhcVersionChecker -> SpliceQ GhcVersionChecker)
-> SpliceQ GhcVersionChecker -> SpliceQ GhcVersionChecker
forall a b. (a -> b) -> a -> b
$ do
  [(String, PackageVersion)]
compileTimeVersions <- IO [(String, PackageVersion)] -> Q [(String, PackageVersion)]
forall a. IO a -> Q a
TH.runIO (IO [(String, PackageVersion)] -> Q [(String, PackageVersion)])
-> IO [(String, PackageVersion)] -> Q [(String, PackageVersion)]
forall a b. (a -> b) -> a -> b
$ IO String -> IO [(String, PackageVersion)]
getCompileTimeVersions IO String
getLibdir
  SpliceQ GhcVersionChecker -> SpliceQ GhcVersionChecker
forall (m :: * -> *) a. Splice m a -> Splice m a
examineSplice [||checkGhcVersion $$(liftTyped compileTimeVersions)||]


getCompileTimeVersions :: IO FilePath -> IO [(String, PackageVersion)]
getCompileTimeVersions :: IO String -> IO [(String, PackageVersion)]
getCompileTimeVersions IO String
getLibdir = do
#if USE_PACKAGE_ABIS
  String
libdir <- IO String
getLibdir
  Bool
libdirExists <- String -> IO Bool
doesDirectoryExist String
libdir
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
libdirExists
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error
    (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"I could not find a GHC installation at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
libdir
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". Please do a clean rebuild and/or reinstall GHC."
  String
-> Ghc [(String, PackageVersion)] -> IO [(String, PackageVersion)]
forall a. String -> Ghc a -> IO a
runGhcPkg String
libdir (Ghc [(String, PackageVersion)] -> IO [(String, PackageVersion)])
-> Ghc [(String, PackageVersion)] -> IO [(String, PackageVersion)]
forall a b. (a -> b) -> a -> b
$ [String] -> Ghc [(String, PackageVersion)]
collectPackageVersions [String
"ghc", String
"base"]

runGhcPkg :: FilePath -> Ghc a -> IO a
runGhcPkg :: String -> Ghc a -> IO a
runGhcPkg String
libdir Ghc a
action = Maybe String -> Ghc a -> IO a
forall a. Maybe String -> Ghc a -> IO a
runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  -- initialize the Ghc session
  -- there's probably a better way to do this.
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dflags
  Ghc a
action
#else
  return
    [ ("ghc", fromVersionString VERSION_ghc)
    , ("base", fromVersionString VERSION_base)
    ]
#endif

-- | A GHC version retrieved from the GHC installation in the given libdir
ghcRunTimeVersion :: String -> IO Version
ghcRunTimeVersion :: String -> IO Version
ghcRunTimeVersion String
libdir = do
  let guesses :: NonEmpty String
guesses = String -> NonEmpty String
guessExecutablePathFromLibdir String
libdir
  [String]
validGuesses <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty String
guesses
  case [String]
validGuesses of
    String
firstGuess : [String]
_ -> String -> IO Version
getGhcVersion String
firstGuess
    [] -> String -> IO Version
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Version) -> String -> IO Version
forall a b. (a -> b) -> a -> b
$ String
"Unable to find the GHC executable for libdir: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
libdir

--------------------------------------------------------------------------------

-- | The result of interpreting a 'PackageCheckResult'
data CompatibilityGuess
  = ProbablyCompatible {CompatibilityGuess -> Maybe String
warning :: Maybe String}
  | NotCompatible {CompatibilityGuess -> NotCompatibleReason
reason :: !NotCompatibleReason}
  deriving (CompatibilityGuess -> CompatibilityGuess -> Bool
(CompatibilityGuess -> CompatibilityGuess -> Bool)
-> (CompatibilityGuess -> CompatibilityGuess -> Bool)
-> Eq CompatibilityGuess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompatibilityGuess -> CompatibilityGuess -> Bool
$c/= :: CompatibilityGuess -> CompatibilityGuess -> Bool
== :: CompatibilityGuess -> CompatibilityGuess -> Bool
$c== :: CompatibilityGuess -> CompatibilityGuess -> Bool
Eq, Int -> CompatibilityGuess -> ShowS
[CompatibilityGuess] -> ShowS
CompatibilityGuess -> String
(Int -> CompatibilityGuess -> ShowS)
-> (CompatibilityGuess -> String)
-> ([CompatibilityGuess] -> ShowS)
-> Show CompatibilityGuess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompatibilityGuess] -> ShowS
$cshowList :: [CompatibilityGuess] -> ShowS
show :: CompatibilityGuess -> String
$cshow :: CompatibilityGuess -> String
showsPrec :: Int -> CompatibilityGuess -> ShowS
$cshowsPrec :: Int -> CompatibilityGuess -> ShowS
Show)

data NotCompatibleReason
  = PackageVersionMismatch
      { NotCompatibleReason -> Version
compileTime :: !Version,
        NotCompatibleReason -> Version
runTime :: !Version,
        NotCompatibleReason -> String
packageName :: !String
      }
  | BasePackageAbiMismatch
      { NotCompatibleReason -> String
compileTimeAbi :: !String,
        NotCompatibleReason -> String
runTimeAbi :: !String,
        compileTime :: !Version
      }
  deriving (NotCompatibleReason -> NotCompatibleReason -> Bool
(NotCompatibleReason -> NotCompatibleReason -> Bool)
-> (NotCompatibleReason -> NotCompatibleReason -> Bool)
-> Eq NotCompatibleReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotCompatibleReason -> NotCompatibleReason -> Bool
$c/= :: NotCompatibleReason -> NotCompatibleReason -> Bool
== :: NotCompatibleReason -> NotCompatibleReason -> Bool
$c== :: NotCompatibleReason -> NotCompatibleReason -> Bool
Eq, Int -> NotCompatibleReason -> ShowS
[NotCompatibleReason] -> ShowS
NotCompatibleReason -> String
(Int -> NotCompatibleReason -> ShowS)
-> (NotCompatibleReason -> String)
-> ([NotCompatibleReason] -> ShowS)
-> Show NotCompatibleReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotCompatibleReason] -> ShowS
$cshowList :: [NotCompatibleReason] -> ShowS
show :: NotCompatibleReason -> String
$cshow :: NotCompatibleReason -> String
showsPrec :: Int -> NotCompatibleReason -> ShowS
$cshowsPrec :: Int -> NotCompatibleReason -> ShowS
Show)

-- | Interpret a 'PackageCheckResult' into a yes/no GHC compatibility answer
guessCompatibility :: PackageCheckResult -> CompatibilityGuess
guessCompatibility :: PackageCheckResult -> CompatibilityGuess
guessCompatibility PackageCheckResult
result = case PackageCheckResult
result of
  PackageCheckFailure NonEmpty (String, PackageCheck)
evidence
    | Just (String, PackageCheck)
problem <- NonEmpty (String, PackageCheck) -> Maybe (String, PackageCheck)
findInterestingProblem NonEmpty (String, PackageCheck)
evidence -> do
      case (String, PackageCheck)
problem of
        (String
packageName, VersionMismatch {Version
runTime :: Version
compileTime :: Version
$sel:runTime:VersionMismatch :: PackageCheck -> Version
$sel:compileTime:VersionMismatch :: PackageCheck -> Version
..}) ->
          NotCompatibleReason -> CompatibilityGuess
NotCompatible PackageVersionMismatch :: Version -> Version -> String -> NotCompatibleReason
PackageVersionMismatch {String
Version
runTime :: Version
compileTime :: Version
packageName :: String
$sel:packageName:PackageVersionMismatch :: String
$sel:runTime:PackageVersionMismatch :: Version
$sel:compileTime:PackageVersionMismatch :: Version
..}
        (String
"base", AbiMismatch {String
Version
compileTime :: Version
runTimeAbi :: String
compileTimeAbi :: String
$sel:runTimeAbi:VersionMismatch :: PackageCheck -> String
$sel:compileTimeAbi:VersionMismatch :: PackageCheck -> String
$sel:compileTime:VersionMismatch :: PackageCheck -> Version
..}) ->
          NotCompatibleReason -> CompatibilityGuess
NotCompatible BasePackageAbiMismatch :: String -> String -> Version -> NotCompatibleReason
BasePackageAbiMismatch {String
Version
compileTime :: Version
runTimeAbi :: String
compileTimeAbi :: String
$sel:runTimeAbi:PackageVersionMismatch :: String
$sel:compileTimeAbi:PackageVersionMismatch :: String
$sel:compileTime:PackageVersionMismatch :: Version
..}
        (String
_, VersionMatch {}) ->
          Maybe String -> CompatibilityGuess
ProbablyCompatible Maybe String
forall a. Maybe a
Nothing
    | Bool
otherwise ->
      Maybe String -> CompatibilityGuess
ProbablyCompatible Maybe String
forall a. Maybe a
Nothing
  PackageCheckInconclusive [String]
attempts ->
    Maybe String -> CompatibilityGuess
ProbablyCompatible (Maybe String -> CompatibilityGuess)
-> Maybe String -> CompatibilityGuess
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
      String
"unable to validate GHC version. Could not find any run-time packages to test: "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
attempts
  PackageCheckError SomeException
err ->
    Maybe String -> CompatibilityGuess
ProbablyCompatible (Maybe String -> CompatibilityGuess)
-> Maybe String -> CompatibilityGuess
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Warning: unable to validate GHC version: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
err
  PackageCheckSuccess !NonEmpty (String, PackageCheck)
_evidence ->
    Maybe String -> CompatibilityGuess
ProbablyCompatible Maybe String
forall a. Maybe a
Nothing

findInterestingProblem :: NonEmpty (String, PackageCheck) -> Maybe (String, PackageCheck)
findInterestingProblem :: NonEmpty (String, PackageCheck) -> Maybe (String, PackageCheck)
findInterestingProblem NonEmpty (String, PackageCheck)
evidence = ((String, PackageCheck) -> Bool)
-> NonEmpty (String, PackageCheck) -> Maybe (String, PackageCheck)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String, PackageCheck) -> Bool
forall a. (a, PackageCheck) -> Bool
isInterestingProblem NonEmpty (String, PackageCheck)
evidence
  where
    ghcVersionMatches :: Bool
ghcVersionMatches = ((String, PackageCheck) -> Bool)
-> NonEmpty (String, PackageCheck) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String, PackageCheck) -> Bool
isGhcVersionMatchEvidence NonEmpty (String, PackageCheck)
evidence
    isInterestingProblem :: (a, PackageCheck) -> Bool
isInterestingProblem (a
_, VersionMismatch {}) = Bool
True
    isInterestingProblem (a
_, AbiMismatch {}) =
      -- The package version matches, but the abi does not.
      -- This can happen if we have been built by:
      --   1) a different version of ghc, or
      --   2) a different build tool
      -- We tolerate only if there is evidence that it's not case 1
      Bool -> Bool
not Bool
ghcVersionMatches

    isInterestingProblem (a, PackageCheck)
_ = Bool
False
    isGhcVersionMatchEvidence :: (String, PackageCheck) -> Bool
isGhcVersionMatchEvidence (String
"ghc", VersionMatch {}) = Bool
True
    isGhcVersionMatchEvidence (String
"ghc", AbiMismatch {}) =
      -- We assume that an abi mismatch implies a version match,
      -- otherwise the library would have reported version mismatch
      -- rather than abi mismatch.
      Bool
True
    isGhcVersionMatchEvidence (String, PackageCheck)
_ = Bool
False