{-# 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,
    fromVersionString
   )
where

import Control.Monad.Trans.Class as Monad (MonadTrans (lift))
import Data.String (IsString (fromString))
import Data.Version (Version)
import GHC
  (pkgState,  Ghc,
    getSessionDynFlags,
  )
import GHC.Check.Util
import Maybes (MaybeT (MaybeT), runMaybeT)
import Module (componentIdToInstalledUnitId)
import PackageConfig (PackageName (PackageName))
import Packages
  (lookupPackage, explicitPackages,  lookupInstalledPackage,
    lookupPackageName
  )
import Packages (InstalledPackageInfo (..))
import Packages (PackageConfig)
import Language.Haskell.TH.Syntax (Lift)
import Data.Foldable (find)
import Packages (packageNameString)
import Control.Applicative (Alternative((<|>)))
import GHC.Stack (HasCallStack)

data PackageVersion
  = PackageVersion
      { PackageVersion -> MyVersion
myVersion :: !MyVersion,
        PackageVersion -> Maybe String
abi :: Maybe String
      }
  deriving (PackageVersion -> PackageVersion -> Bool
(PackageVersion -> PackageVersion -> Bool)
-> (PackageVersion -> PackageVersion -> Bool) -> Eq PackageVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageVersion -> PackageVersion -> Bool
$c/= :: PackageVersion -> PackageVersion -> Bool
== :: PackageVersion -> PackageVersion -> Bool
$c== :: PackageVersion -> PackageVersion -> Bool
Eq, PackageVersion -> Q Exp
PackageVersion -> Q (TExp PackageVersion)
(PackageVersion -> Q Exp)
-> (PackageVersion -> Q (TExp PackageVersion))
-> Lift PackageVersion
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PackageVersion -> Q (TExp PackageVersion)
$cliftTyped :: PackageVersion -> Q (TExp PackageVersion)
lift :: PackageVersion -> Q Exp
$clift :: PackageVersion -> Q Exp
Lift, Int -> PackageVersion -> ShowS
[PackageVersion] -> ShowS
PackageVersion -> String
(Int -> PackageVersion -> ShowS)
-> (PackageVersion -> String)
-> ([PackageVersion] -> ShowS)
-> Show PackageVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageVersion] -> ShowS
$cshowList :: [PackageVersion] -> ShowS
show :: PackageVersion -> String
$cshow :: PackageVersion -> String
showsPrec :: Int -> PackageVersion -> ShowS
$cshowsPrec :: Int -> PackageVersion -> ShowS
Show)

version :: PackageVersion -> Version
version :: PackageVersion -> Version
version PackageVersion{ myVersion :: PackageVersion -> MyVersion
myVersion = MyVersion Version
v} = Version
v

-- | @getPackageVersion p@ returns the version of package @p@ that will be used in the Ghc session.
getPackageVersion :: String -> Ghc (Maybe PackageVersion)
getPackageVersion :: String -> Ghc (Maybe PackageVersion)
getPackageVersion String
pName = MaybeT Ghc PackageVersion -> Ghc (Maybe PackageVersion)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Ghc PackageVersion -> Ghc (Maybe PackageVersion))
-> MaybeT Ghc PackageVersion -> Ghc (Maybe PackageVersion)
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- Ghc DynFlags -> MaybeT Ghc DynFlags
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let pkgst :: PackageState
pkgst   = DynFlags -> PackageState
pkgState DynFlags
dflags
      depends :: [UnitId]
depends = PackageState -> [UnitId]
explicitPackages PackageState
pkgst

  let explicit :: MaybeT Ghc PackageConfig
explicit = do
        [PackageConfig]
pkgs <- (UnitId -> MaybeT Ghc PackageConfig)
-> [UnitId] -> MaybeT Ghc [PackageConfig]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig)
-> (UnitId -> Ghc (Maybe PackageConfig))
-> UnitId
-> MaybeT Ghc PackageConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PackageConfig -> Ghc (Maybe PackageConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageConfig -> Ghc (Maybe PackageConfig))
-> (UnitId -> Maybe PackageConfig)
-> UnitId
-> Ghc (Maybe PackageConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags) [UnitId]
depends
        Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig)
-> Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig
forall a b. (a -> b) -> a -> b
$ Maybe PackageConfig -> Ghc (Maybe PackageConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageConfig -> Ghc (Maybe PackageConfig))
-> Maybe PackageConfig -> Ghc (Maybe PackageConfig)
forall a b. (a -> b) -> a -> b
$ (PackageConfig -> Bool) -> [PackageConfig] -> Maybe PackageConfig
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\PackageConfig
p -> PackageConfig -> String
packageNameString PackageConfig
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pName ) [PackageConfig]
pkgs

      notExplicit :: MaybeT Ghc PackageConfig
notExplicit = do
        ComponentId
component <- Ghc (Maybe ComponentId) -> MaybeT Ghc ComponentId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Ghc (Maybe ComponentId) -> MaybeT Ghc ComponentId)
-> Ghc (Maybe ComponentId) -> MaybeT Ghc ComponentId
forall a b. (a -> b) -> a -> b
$ Maybe ComponentId -> Ghc (Maybe ComponentId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComponentId -> Ghc (Maybe ComponentId))
-> Maybe ComponentId -> Ghc (Maybe ComponentId)
forall a b. (a -> b) -> a -> b
$ DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName DynFlags
dflags (PackageName -> Maybe ComponentId)
-> PackageName -> Maybe ComponentId
forall a b. (a -> b) -> a -> b
$ FastString -> PackageName
PackageName (FastString -> PackageName) -> FastString -> PackageName
forall a b. (a -> b) -> a -> b
$ String -> FastString
forall a. IsString a => String -> a
fromString String
pName
        Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig)
-> Ghc (Maybe PackageConfig) -> MaybeT Ghc PackageConfig
forall a b. (a -> b) -> a -> b
$ Maybe PackageConfig -> Ghc (Maybe PackageConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageConfig -> Ghc (Maybe PackageConfig))
-> Maybe PackageConfig -> Ghc (Maybe PackageConfig)
forall a b. (a -> b) -> a -> b
$ DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags (ComponentId -> InstalledUnitId
componentIdToInstalledUnitId ComponentId
component)

  PackageConfig
p <- MaybeT Ghc PackageConfig
explicit MaybeT Ghc PackageConfig
-> MaybeT Ghc PackageConfig -> MaybeT Ghc PackageConfig
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Ghc PackageConfig
notExplicit

  PackageVersion -> MaybeT Ghc PackageVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageVersion -> MaybeT Ghc PackageVersion)
-> PackageVersion -> MaybeT Ghc PackageVersion
forall a b. (a -> b) -> a -> b
$ PackageConfig -> PackageVersion
fromPackageConfig PackageConfig
p

fromPackageConfig :: PackageConfig -> PackageVersion
fromPackageConfig :: PackageConfig -> PackageVersion
fromPackageConfig PackageConfig
p = MyVersion -> Maybe String -> PackageVersion
PackageVersion (Version -> MyVersion
MyVersion (Version -> MyVersion) -> Version -> MyVersion
forall a b. (a -> b) -> a -> b
$ PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
packageVersion PackageConfig
p) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ PackageConfig -> String
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> String
abiHash PackageConfig
p)

fromVersionString :: HasCallStack => String -> PackageVersion
fromVersionString :: String -> PackageVersion
fromVersionString String
v = MyVersion -> Maybe String -> PackageVersion
PackageVersion (Version -> MyVersion
MyVersion (Version -> MyVersion) -> Version -> MyVersion
forall a b. (a -> b) -> a -> b
$ String -> Version
forall a. Read a => String -> a
read String
v) Maybe String
forall a. Maybe a
Nothing