module Development.IDE.Types.HscEnvEq
(   HscEnvEq,
    hscEnv, newHscEnvEq,
    hscEnvWithImportPaths,
    newHscEnvEqPreserveImportPaths,
    newHscEnvEqWithImportPaths,
    envImportPaths,
    envPackageExports,
    deps
) where


import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
import Data.Unique
import Development.Shake.Classes
import Module (InstalledUnitId)
import System.Directory (canonicalizePath)
import Development.IDE.GHC.Compat
import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId)
import System.FilePath
import Development.IDE.GHC.Util (lookupPackageConfig)
import Control.Monad.IO.Class
import TcRnMonad (initIfaceLoad, WhereFrom (ImportByUser))
import LoadIface (loadInterface)
import qualified Maybes
import OpenTelemetry.Eventlog (withSpan)
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.Extra (mapMaybeM)

-- | An 'HscEnv' with equality. Two values are considered equal
--   if they are created with the same call to 'newHscEnvEq'.
data HscEnvEq = HscEnvEq
    { HscEnvEq -> Unique
envUnique :: !Unique
    , HscEnvEq -> HscEnv
hscEnv :: !HscEnv
    , HscEnvEq -> [(InstalledUnitId, DynFlags)]
deps   :: [(InstalledUnitId, DynFlags)]
               -- ^ In memory components for this HscEnv
               -- This is only used at the moment for the import dirs in
               -- the DynFlags
    , HscEnvEq -> Maybe [String]
envImportPaths :: Maybe [String]
        -- ^ If Just, import dirs originally configured in this env
        --   If Nothing, the env import dirs are unaltered
    , HscEnvEq -> ExportsMap
envPackageExports :: ExportsMap
    }

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq :: String -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq String
cradlePath HscEnv
hscEnv0 [(InstalledUnitId, DynFlags)]
deps = do
    let relativeToCradle :: String -> String
relativeToCradle = (String -> String
takeDirectory String
cradlePath String -> String -> String
</>)
        hscEnv :: HscEnv
hscEnv = HscEnv -> HscEnv
removeImportPaths HscEnv
hscEnv0

    -- Canonicalize import paths since we also canonicalize targets
    [String]
importPathsCanon <-
      (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
canonicalizePath ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String
relativeToCradle (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [String]
importPaths (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv0)

    Maybe [String]
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
importPathsCanon) HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps

newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths :: Maybe [String]
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe [String]
envImportPaths HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps = do
    Unique
envUnique <- IO Unique
newUnique

    let
    -- evaluate lazily, using unsafePerformIO for a pure API
      envPackageExports :: ExportsMap
envPackageExports = IO ExportsMap -> ExportsMap
forall a. IO a -> a
unsafePerformIO (IO ExportsMap -> ExportsMap) -> IO ExportsMap -> ExportsMap
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO ExportsMap) -> IO ExportsMap
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Package Exports" ((SpanInFlight -> IO ExportsMap) -> IO ExportsMap)
-> (SpanInFlight -> IO ExportsMap) -> IO ExportsMap
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
_sp -> do
        -- compute the package imports
        let pkgst :: PackageState
pkgst   = DynFlags -> PackageState
pkgState (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv)
            depends :: [UnitId]
depends = PackageState -> [UnitId]
explicitPackages PackageState
pkgst
            targets :: [(PackageConfig, ModuleName)]
targets =
                [ (PackageConfig
pkg, ModuleName
mn)
                | UnitId
d        <- [UnitId]
depends
                , Just PackageConfig
pkg <- [UnitId -> HscEnv -> Maybe PackageConfig
lookupPackageConfig UnitId
d HscEnv
hscEnv]
                , (ModuleName
mn, Maybe Module
_)  <- PackageConfig -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [(modulename, Maybe mod)]
exposedModules PackageConfig
pkg
                ]

            doOne :: (PackageConfig, ModuleName) -> m (Maybe ModIface)
doOne (PackageConfig
pkg, ModuleName
mn) = do
                MaybeErr MsgDoc ModIface
modIface <- IO (MaybeErr MsgDoc ModIface) -> m (MaybeErr MsgDoc ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MaybeErr MsgDoc ModIface) -> m (MaybeErr MsgDoc ModIface))
-> IO (MaybeErr MsgDoc ModIface) -> m (MaybeErr MsgDoc ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> IfG (MaybeErr MsgDoc ModIface) -> IO (MaybeErr MsgDoc ModIface)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hscEnv (IfG (MaybeErr MsgDoc ModIface) -> IO (MaybeErr MsgDoc ModIface))
-> IfG (MaybeErr MsgDoc ModIface) -> IO (MaybeErr MsgDoc ModIface)
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Module -> WhereFrom -> IfG (MaybeErr MsgDoc ModIface)
forall lcl.
MsgDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr MsgDoc ModIface)
loadInterface
                    MsgDoc
""
                    (UnitId -> ModuleName -> Module
Module (PackageConfig -> UnitId
packageConfigId PackageConfig
pkg) ModuleName
mn)
                    (IsBootInterface -> WhereFrom
ImportByUser IsBootInterface
False)
                Maybe ModIface -> m (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModIface -> m (Maybe ModIface))
-> Maybe ModIface -> m (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ case MaybeErr MsgDoc ModIface
modIface of
                    Maybes.Failed    MsgDoc
_r -> Maybe ModIface
forall a. Maybe a
Nothing
                    Maybes.Succeeded ModIface
mi -> ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
mi
        [ModIface]
modIfaces <- ((PackageConfig, ModuleName) -> IO (Maybe ModIface))
-> [(PackageConfig, ModuleName)] -> IO [ModIface]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (PackageConfig, ModuleName) -> IO (Maybe ModIface)
forall (m :: * -> *).
MonadIO m =>
(PackageConfig, ModuleName) -> m (Maybe ModIface)
doOne [(PackageConfig, ModuleName)]
targets
        ExportsMap -> IO ExportsMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ExportsMap -> IO ExportsMap) -> ExportsMap -> IO ExportsMap
forall a b. (a -> b) -> a -> b
$ [ModIface] -> ExportsMap
createExportsMap [ModIface]
modIfaces
    HscEnvEq -> IO HscEnvEq
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnvEq :: Unique
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> Maybe [String]
-> ExportsMap
-> HscEnvEq
HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
ExportsMap
envPackageExports :: ExportsMap
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envImportPaths :: Maybe [String]
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envPackageExports :: ExportsMap
envImportPaths :: Maybe [String]
hscEnv :: HscEnv
..}

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEqPreserveImportPaths
    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths = Maybe [String]
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe [String]
forall a. Maybe a
Nothing

-- | Unwrap the 'HscEnv' with the original import paths.
--   Used only for locating imports
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
ExportsMap
envPackageExports :: ExportsMap
envImportPaths :: Maybe [String]
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
envPackageExports :: HscEnvEq -> ExportsMap
envImportPaths :: HscEnvEq -> Maybe [String]
hscEnv :: HscEnvEq -> HscEnv
..}
    | Just [String]
imps <- Maybe [String]
envImportPaths
    = HscEnv
hscEnv{hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv){importPaths :: [String]
importPaths = [String]
imps}}
    | IsBootInterface
otherwise
    = HscEnv
hscEnv

removeImportPaths :: HscEnv -> HscEnv
removeImportPaths :: HscEnv -> HscEnv
removeImportPaths HscEnv
hsc = HscEnv
hsc{hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc){importPaths :: [String]
importPaths = []}}

instance Show HscEnvEq where
  show :: HscEnvEq -> String
show HscEnvEq{Unique
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
envUnique} = String
"HscEnvEq " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Unique -> Int
hashUnique Unique
envUnique)

instance Eq HscEnvEq where
  HscEnvEq
a == :: HscEnvEq -> HscEnvEq -> IsBootInterface
== HscEnvEq
b = HscEnvEq -> Unique
envUnique HscEnvEq
a Unique -> Unique -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
== HscEnvEq -> Unique
envUnique HscEnvEq
b

instance NFData HscEnvEq where
  rnf :: HscEnvEq -> ()
rnf (HscEnvEq Unique
a HscEnv
b [(InstalledUnitId, DynFlags)]
c Maybe [String]
d ExportsMap
_) =
      -- deliberately skip the package exports map
      Int -> ()
forall a. NFData a => a -> ()
rnf (Unique -> Int
hashUnique Unique
a) () -> () -> ()
`seq` HscEnv
b HscEnv -> () -> ()
`seq` [(InstalledUnitId, DynFlags)]
c [(InstalledUnitId, DynFlags)] -> () -> ()
`seq` Maybe [String] -> ()
forall a. NFData a => a -> ()
rnf Maybe [String]
d

instance Hashable HscEnvEq where
  hashWithSalt :: Int -> HscEnvEq -> Int
hashWithSalt Int
s = Int -> Unique -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Unique -> Int) -> (HscEnvEq -> Unique) -> HscEnvEq -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> Unique
envUnique

-- Fake instance needed to persuade Shake to accept this type as a key.
-- No harm done as ghcide never persists these keys currently
instance Binary HscEnvEq where
  put :: HscEnvEq -> Put
put HscEnvEq
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"not really"
  get :: Get HscEnvEq
get = String -> Get HscEnvEq
forall a. HasCallStack => String -> a
error String
"not really"