{-# LANGUAGE CPP #-}

-- | Compat module for 'UnitState' and 'UnitInfo'.
module Development.IDE.GHC.Compat.Units (
    -- * UnitState
    UnitState,
    initUnits,
    oldInitUnits,
    unitState,
    getUnitName,
    explicitUnits,
    preloadClosureUs,
    listVisibleModuleNames,
    LookupResult(..),
    lookupModuleWithSuggestions,
    -- * UnitInfoMap
    UnitInfoMap,
    getUnitInfoMap,
    lookupUnit,
    lookupUnit',
    -- * UnitInfo
    UnitInfo,
    unitExposedModules,
    unitDepends,
    unitHaddockInterfaces,
    mkUnit,
    unitPackageNameString,
    unitPackageVersion,
    -- * UnitId helpers
    UnitId,
    Unit,
    unitString,
    stringToUnit,
    definiteUnitId,
    defUnitId,
    installedModule,
    -- * Module
    toUnitId,
    moduleUnitId,
    moduleUnit,
    -- * ExternalPackageState
    ExternalPackageState(..),
    -- * Utils
    filterInplaceUnits,
    FinderCache,
    showSDocForUser',
    findImportedModule,
    ) where

import           Data.Either
import           Development.IDE.GHC.Compat.Core
import           Development.IDE.GHC.Compat.Env
import           Development.IDE.GHC.Compat.Outputable
import           Prelude                               hiding (mod)

import qualified GHC.Data.ShortText                    as ST
import           GHC.Types.Unique.Set
import           GHC.Unit.External
import qualified GHC.Unit.Finder                       as GHC
import qualified GHC.Unit.Info                         as UnitInfo
import           GHC.Unit.State                        (LookupResult, UnitInfo,
                                                        UnitInfoMap,
                                                        UnitState (unitInfoMap),
                                                        lookupUnit', mkUnit,
                                                        unitDepends,
                                                        unitExposedModules,
                                                        unitPackageNameString,
                                                        unitPackageVersion)
import qualified GHC.Unit.State                        as State
import           GHC.Unit.Types

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

#if !MIN_VERSION_ghc(9,3,0)
import           GHC.Data.FastString
import           GHC.Unit.Env
import           GHC.Unit.Finder                       hiding
                                                       (findImportedModule)
import qualified GHC.Unit.Types                        as Unit
#endif

#if MIN_VERSION_ghc(9,3,0)
import           Control.Monad
import qualified Data.List.NonEmpty                    as NE
import qualified Data.Map.Strict                       as Map
import qualified GHC
import qualified GHC.Driver.Session                    as DynFlags
import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual))
import           GHC.Unit.Home.ModInfo
#endif


type PreloadUnitClosure = UniqSet UnitId

unitState :: HscEnv -> UnitState
unitState :: HscEnv -> UnitState
unitState = (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (UnitEnv -> UnitState)
-> (HscEnv -> UnitEnv) -> HscEnv -> UnitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env

#if MIN_VERSION_ghc(9,3,0)
createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph
createUnitEnvFromFlags :: NonEmpty DynFlags -> HomeUnitGraph
createUnitEnvFromFlags NonEmpty DynFlags
unitDflags =
  let
    newInternalUnitEnv :: DynFlags -> HomeUnitEnv
newInternalUnitEnv DynFlags
dflags = DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags HomePackageTable
emptyHomePackageTable Maybe HomeUnit
forall a. Maybe a
Nothing
    unitEnvList :: NonEmpty (UnitId, HomeUnitEnv)
unitEnvList = (DynFlags -> (UnitId, HomeUnitEnv))
-> NonEmpty DynFlags -> NonEmpty (UnitId, HomeUnitEnv)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\DynFlags
dflags -> (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags, DynFlags -> HomeUnitEnv
newInternalUnitEnv DynFlags
dflags)) NonEmpty DynFlags
unitDflags
  in
    Map UnitId HomeUnitEnv -> HomeUnitGraph
forall v. Map UnitId v -> UnitEnvGraph v
unitEnv_new ([(UnitId, HomeUnitEnv)] -> Map UnitId HomeUnitEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (NonEmpty (UnitId, HomeUnitEnv) -> [(UnitId, HomeUnitEnv)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (UnitId, HomeUnitEnv)
unitEnvList)))

initUnits :: [DynFlags] -> HscEnv -> IO HscEnv
initUnits :: [DynFlags] -> HscEnv -> IO HscEnv
initUnits [DynFlags]
unitDflags HscEnv
env = do
  let dflags0 :: DynFlags
dflags0         = HscEnv -> DynFlags
hsc_dflags HscEnv
env
  -- additionally, set checked dflags so we don't lose fixes
  let initial_home_graph :: HomeUnitGraph
initial_home_graph = NonEmpty DynFlags -> HomeUnitGraph
createUnitEnvFromFlags (DynFlags
dflags0 DynFlags -> [DynFlags] -> NonEmpty DynFlags
forall a. a -> [a] -> NonEmpty a
NE.:| [DynFlags]
unitDflags)
      home_units :: Set UnitId
home_units = HomeUnitGraph -> Set UnitId
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys HomeUnitGraph
initial_home_graph
  HomeUnitGraph
home_unit_graph <- HomeUnitGraph
-> (HomeUnitEnv -> IO HomeUnitEnv) -> IO HomeUnitGraph
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM HomeUnitGraph
initial_home_graph ((HomeUnitEnv -> IO HomeUnitEnv) -> IO HomeUnitGraph)
-> (HomeUnitEnv -> IO HomeUnitEnv) -> IO HomeUnitGraph
forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
homeUnitEnv -> do
    let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs HomeUnitEnv
homeUnitEnv
        dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
        old_hpt :: HomePackageTable
old_hpt = HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
homeUnitEnv

    ([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
State.initUnits (HscEnv -> Logger
hsc_logger HscEnv
env) DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_unit_dbs Set UnitId
home_units

    DynFlags
updated_dflags <- DynFlags -> Maybe PlatformConstants -> IO DynFlags
DynFlags.updatePlatformConstants DynFlags
dflags Maybe PlatformConstants
mconstants
    HomeUnitEnv -> IO HomeUnitEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HomeUnitEnv
      { homeUnitEnv_units :: UnitState
homeUnitEnv_units = UnitState
unit_state
      , homeUnitEnv_unit_dbs :: Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
      , homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
updated_dflags
      , homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
old_hpt
      , homeUnitEnv_home_unit :: Maybe HomeUnit
homeUnitEnv_home_unit = HomeUnit -> Maybe HomeUnit
forall a. a -> Maybe a
Just HomeUnit
home_unit
      }

  let dflags1 :: DynFlags
dflags1 = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitId -> HomeUnitGraph -> HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags0) HomeUnitGraph
home_unit_graph
  let unit_env :: UnitEnv
unit_env = UnitEnv
        { ue_platform :: Platform
ue_platform        = DynFlags -> Platform
targetPlatform DynFlags
dflags1
        , ue_namever :: GhcNameVersion
ue_namever         = DynFlags -> GhcNameVersion
GHC.ghcNameVersion DynFlags
dflags1
        , ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph = HomeUnitGraph
home_unit_graph
        , ue_current_unit :: UnitId
ue_current_unit    = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags0
        , ue_eps :: ExternalUnitCache
ue_eps             = UnitEnv -> ExternalUnitCache
ue_eps (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env)
        }
  HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ UnitEnv -> HscEnv -> HscEnv
hscSetUnitEnv UnitEnv
unit_env HscEnv
env
#else
initUnits :: [DynFlags] -> HscEnv -> IO HscEnv
initUnits _df env = pure env -- Can't do anything here, oldInitUnits should already be called
#endif


-- | oldInitUnits only needs to modify DynFlags for GHC <9.2
-- For GHC >= 9.2, we need to set the hsc_unit_env also, that is
-- done later by initUnits
oldInitUnits :: DynFlags -> IO DynFlags
oldInitUnits :: DynFlags -> IO DynFlags
oldInitUnits = DynFlags -> IO DynFlags
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

explicitUnits :: UnitState -> [Unit]
explicitUnits :: UnitState -> [Unit]
explicitUnits UnitState
ue =
#if MIN_VERSION_ghc(9,3,0)
  ((Unit, Maybe PackageArg) -> Unit)
-> [(Unit, Maybe PackageArg)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (Unit, Maybe PackageArg) -> Unit
forall a b. (a, b) -> a
fst ([(Unit, Maybe PackageArg)] -> [Unit])
-> [(Unit, Maybe PackageArg)] -> [Unit]
forall a b. (a -> b) -> a -> b
$ UnitState -> [(Unit, Maybe PackageArg)]
State.explicitUnits UnitState
ue
#else
  State.explicitUnits ue
#endif

listVisibleModuleNames :: HscEnv -> [ModuleName]
listVisibleModuleNames :: HscEnv -> [ModuleName]
listVisibleModuleNames HscEnv
env =
  UnitState -> [ModuleName]
State.listVisibleModuleNames (UnitState -> [ModuleName]) -> UnitState -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitState
unitState HscEnv
env

getUnitName :: HscEnv -> UnitId -> Maybe PackageName
getUnitName :: HscEnv -> UnitId -> Maybe PackageName
getUnitName HscEnv
env UnitId
i =
  GenericUnitInfo
  PackageId PackageName UnitId ModuleName (GenModule Unit)
-> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
State.unitPackageName (GenericUnitInfo
   PackageId PackageName UnitId ModuleName (GenModule Unit)
 -> PackageName)
-> Maybe
     (GenericUnitInfo
        PackageId PackageName UnitId ModuleName (GenModule Unit))
-> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitState
-> UnitId
-> Maybe
     (GenericUnitInfo
        PackageId PackageName UnitId ModuleName (GenModule Unit))
State.lookupUnitId (HscEnv -> UnitState
unitState HscEnv
env) UnitId
i

lookupModuleWithSuggestions
  :: HscEnv
  -> ModuleName
#if MIN_VERSION_ghc(9,3,0)
  -> GHC.PkgQual
#else
  -> Maybe FastString
#endif
  -> LookupResult
lookupModuleWithSuggestions :: HscEnv -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions HscEnv
env ModuleName
modname PkgQual
mpkg =
  UnitState -> ModuleName -> PkgQual -> LookupResult
State.lookupModuleWithSuggestions (HscEnv -> UnitState
unitState HscEnv
env) ModuleName
modname PkgQual
mpkg

getUnitInfoMap :: HscEnv -> UnitInfoMap
getUnitInfoMap :: HscEnv -> UnitInfoMap
getUnitInfoMap =
  UnitState -> UnitInfoMap
unitInfoMap (UnitState -> UnitInfoMap)
-> (HscEnv -> UnitState) -> HscEnv -> UnitInfoMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (UnitEnv -> UnitState)
-> (HscEnv -> UnitEnv) -> HscEnv -> UnitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env

lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo
lookupUnit :: HscEnv
-> Unit
-> Maybe
     (GenericUnitInfo
        PackageId PackageName UnitId ModuleName (GenModule Unit))
lookupUnit HscEnv
env Unit
pid = UnitState
-> Unit
-> Maybe
     (GenericUnitInfo
        PackageId PackageName UnitId ModuleName (GenModule Unit))
State.lookupUnit (HscEnv -> UnitState
unitState HscEnv
env) Unit
pid

preloadClosureUs :: HscEnv -> PreloadUnitClosure
preloadClosureUs :: HscEnv -> PreloadUnitClosure
preloadClosureUs = UnitState -> PreloadUnitClosure
State.preloadClosure (UnitState -> PreloadUnitClosure)
-> (HscEnv -> UnitState) -> HscEnv -> PreloadUnitClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitState
unitState

unitHaddockInterfaces :: UnitInfo -> [FilePath]
unitHaddockInterfaces :: GenericUnitInfo
  PackageId PackageName UnitId ModuleName (GenModule Unit)
-> [FilePath]
unitHaddockInterfaces =
  (ShortText -> FilePath) -> [ShortText] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortText -> FilePath
ST.unpack ([ShortText] -> [FilePath])
-> (GenericUnitInfo
      PackageId PackageName UnitId ModuleName (GenModule Unit)
    -> [ShortText])
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo
  PackageId PackageName UnitId ModuleName (GenModule Unit)
-> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
UnitInfo.unitHaddockInterfaces

-- ------------------------------------------------------------------
-- Backwards Compatible UnitState
-- ------------------------------------------------------------------

-- ------------------------------------------------------------------
-- Patterns and helpful definitions
-- ------------------------------------------------------------------

definiteUnitId :: Definite uid -> GenUnit uid
definiteUnitId :: forall uid. Definite uid -> GenUnit uid
definiteUnitId         = Definite uid -> GenUnit uid
forall uid. Definite uid -> GenUnit uid
RealUnit
defUnitId :: unit -> Definite unit
defUnitId :: forall unit. unit -> Definite unit
defUnitId              = unit -> Definite unit
forall unit. unit -> Definite unit
Definite
installedModule :: unit -> ModuleName -> GenModule unit
installedModule :: forall unit. unit -> ModuleName -> GenModule unit
installedModule        = unit -> ModuleName -> GenModule unit
forall unit. unit -> ModuleName -> GenModule unit
Module

#if !MIN_VERSION_ghc(9,3,0)
moduleUnitId :: Module -> UnitId
moduleUnitId = Unit.toUnitId . Unit.moduleUnit
#endif

filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag])
filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag])
filterInplaceUnits [UnitId]
us [PackageFlag]
packageFlags =
  [Either UnitId PackageFlag] -> ([UnitId], [PackageFlag])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((PackageFlag -> Either UnitId PackageFlag)
-> [PackageFlag] -> [Either UnitId PackageFlag]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> Either UnitId PackageFlag
isInplace [PackageFlag]
packageFlags)
  where
    isInplace :: PackageFlag -> Either UnitId PackageFlag
    isInplace :: PackageFlag -> Either UnitId PackageFlag
isInplace p :: PackageFlag
p@(ExposePackage FilePath
_ (UnitIdArg Unit
u) ModRenaming
_) =
      if Unit -> UnitId
toUnitId Unit
u UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
us
        then UnitId -> Either UnitId PackageFlag
forall a b. a -> Either a b
Left (UnitId -> Either UnitId PackageFlag)
-> UnitId -> Either UnitId PackageFlag
forall a b. (a -> b) -> a -> b
$ Unit -> UnitId
toUnitId  Unit
u
        else PackageFlag -> Either UnitId PackageFlag
forall a b. b -> Either a b
Right PackageFlag
p
    isInplace PackageFlag
p = PackageFlag -> Either UnitId PackageFlag
forall a b. b -> Either a b
Right PackageFlag
p

showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> String
showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> FilePath
showSDocForUser' HscEnv
env = DynFlags -> UnitState -> PrintUnqualified -> SDoc -> FilePath
showSDocForUser (HscEnv -> DynFlags
hsc_dflags HscEnv
env) (HscEnv -> UnitState
unitState HscEnv
env)

findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module)
findImportedModule :: HscEnv -> ModuleName -> IO (Maybe (GenModule Unit))
findImportedModule HscEnv
env ModuleName
mn = do
#if MIN_VERSION_ghc(9,3,0)
    FindResult
res <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
GHC.findImportedModule HscEnv
env ModuleName
mn PkgQual
NoPkgQual
#else
    res <- GHC.findImportedModule env mn Nothing
#endif
    case FindResult
res of
        Found ModLocation
_ GenModule Unit
mod -> Maybe (GenModule Unit) -> IO (Maybe (GenModule Unit))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GenModule Unit) -> IO (Maybe (GenModule Unit)))
-> (GenModule Unit -> Maybe (GenModule Unit))
-> GenModule Unit
-> IO (Maybe (GenModule Unit))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> Maybe (GenModule Unit)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenModule Unit -> IO (Maybe (GenModule Unit)))
-> GenModule Unit -> IO (Maybe (GenModule Unit))
forall a b. (a -> b) -> a -> b
$ GenModule Unit
mod
        FindResult
_           -> Maybe (GenModule Unit) -> IO (Maybe (GenModule Unit))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GenModule Unit)
forall a. Maybe a
Nothing