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


import           Control.Concurrent.Async      (Async, async, waitCatch)
import           Control.Concurrent.Strict     (modifyVar, newVar)
import           Control.DeepSeq               (force)
import           Control.Exception             (evaluate, mask, throwIO)
import           Control.Monad.Extra           (eitherM, join, mapMaybeM)
import           Control.Monad.IO.Class
import           Data.Either                   (fromRight)
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Data.Unique
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Error     (catchSrcErrors)
import           Development.IDE.GHC.Util      (lookupPackageConfig)
import           Development.IDE.Graph.Classes
import           Development.IDE.Types.Exports (ExportsMap, createExportsMap)
import           GhcPlugins                    (HscEnv (hsc_dflags))
import           LoadIface                     (loadInterface)
import qualified Maybes
-- import           Module                        (InstalledUnitId)
import           OpenTelemetry.Eventlog        (withSpan)
import           System.Directory              (canonicalizePath)
import           System.FilePath
import           TcRnMonad                     (WhereFrom (ImportByUser),
                                                initIfaceLoad)

-- | 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 (Set FilePath)
envImportPaths        :: Maybe (Set FilePath)
        -- ^ If Just, import dirs originally configured in this env
        --   If Nothing, the env import dirs are unaltered
    , HscEnvEq -> IO ExportsMap
envPackageExports     :: IO ExportsMap
    , HscEnvEq -> IO (Maybe [ModuleName])
envVisibleModuleNames :: IO (Maybe [ModuleName])
        -- ^ 'listVisibleModuleNames' is a pure function,
        -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365
        -- So it's wrapped in IO here for error handling
        -- If Nothing, 'listVisibleModuleNames' panic
    }

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

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

    Maybe (Set FilePath)
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths (Set FilePath -> Maybe (Set FilePath)
forall a. a -> Maybe a
Just (Set FilePath -> Maybe (Set FilePath))
-> Set FilePath -> Maybe (Set FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
importPathsCanon) HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps

newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths :: Maybe (Set FilePath)
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe (Set FilePath)
envImportPaths HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps = do

    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv

    Unique
envUnique <- IO Unique
newUnique

    -- it's very important to delay the package exports computation
    IO ExportsMap
envPackageExports <- IO ExportsMap -> IO (IO ExportsMap)
forall a. IO a -> IO (IO a)
onceAsync (IO ExportsMap -> IO (IO ExportsMap))
-> IO ExportsMap -> IO (IO 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 DynFlags
dflags
            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) -> f (Maybe ModIface)
doOne (PackageConfig
pkg, ModuleName
mn) = do
                MaybeErr MsgDoc ModIface
modIface <- IO (MaybeErr MsgDoc ModIface) -> f (MaybeErr MsgDoc ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MaybeErr MsgDoc ModIface) -> f (MaybeErr MsgDoc ModIface))
-> IO (MaybeErr MsgDoc ModIface) -> f (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
mkModule (PackageConfig -> UnitId
packageConfigId PackageConfig
pkg) ModuleName
mn)
                    (IsBootInterface -> WhereFrom
ImportByUser IsBootInterface
NotBoot)
                return $ 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 (f :: * -> *).
MonadIO f =>
(PackageConfig, ModuleName) -> f (Maybe ModIface)
doOne [(PackageConfig, ModuleName)]
targets
        return $ [ModIface] -> ExportsMap
createExportsMap [ModIface]
modIfaces

    -- similar to envPackageExports, evaluated lazily
    IO (Maybe [ModuleName])
envVisibleModuleNames <- IO (Maybe [ModuleName]) -> IO (IO (Maybe [ModuleName]))
forall a. IO a -> IO (IO a)
onceAsync (IO (Maybe [ModuleName]) -> IO (IO (Maybe [ModuleName])))
-> IO (Maybe [ModuleName]) -> IO (IO (Maybe [ModuleName]))
forall a b. (a -> b) -> a -> b
$
      Maybe [ModuleName]
-> Either [FileDiagnostic] (Maybe [ModuleName])
-> Maybe [ModuleName]
forall b a. b -> Either a b -> b
fromRight Maybe [ModuleName]
forall a. Maybe a
Nothing
        (Either [FileDiagnostic] (Maybe [ModuleName])
 -> Maybe [ModuleName])
-> IO (Either [FileDiagnostic] (Maybe [ModuleName]))
-> IO (Maybe [ModuleName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags
-> Text
-> IO (Maybe [ModuleName])
-> IO (Either [FileDiagnostic] (Maybe [ModuleName]))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors
          DynFlags
dflags
          Text
"listVisibleModuleNames"
          (Maybe [ModuleName] -> IO (Maybe [ModuleName])
forall a. a -> IO a
evaluate (Maybe [ModuleName] -> IO (Maybe [ModuleName]))
-> ([ModuleName] -> Maybe [ModuleName])
-> [ModuleName]
-> IO (Maybe [ModuleName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [ModuleName] -> Maybe [ModuleName]
forall a. NFData a => a -> a
force (Maybe [ModuleName] -> Maybe [ModuleName])
-> ([ModuleName] -> Maybe [ModuleName])
-> [ModuleName]
-> Maybe [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleName] -> Maybe [ModuleName]
forall a. a -> Maybe a
Just ([ModuleName] -> IO (Maybe [ModuleName]))
-> [ModuleName] -> IO (Maybe [ModuleName])
forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModuleName]
oldListVisibleModuleNames DynFlags
dflags)

    return HscEnvEq :: Unique
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> Maybe (Set FilePath)
-> IO ExportsMap
-> IO (Maybe [ModuleName])
-> HscEnvEq
HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe (Set FilePath)
IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
envVisibleModuleNames :: IO (Maybe [ModuleName])
envPackageExports :: IO ExportsMap
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envImportPaths :: Maybe (Set FilePath)
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envVisibleModuleNames :: IO (Maybe [ModuleName])
envPackageExports :: IO ExportsMap
envImportPaths :: Maybe (Set FilePath)
hscEnv :: HscEnv
..}

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEqPreserveImportPaths
    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths = Maybe (Set FilePath)
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe (Set FilePath)
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 (Set FilePath)
IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
envVisibleModuleNames :: IO (Maybe [ModuleName])
envPackageExports :: IO ExportsMap
envImportPaths :: Maybe (Set FilePath)
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
envVisibleModuleNames :: HscEnvEq -> IO (Maybe [ModuleName])
envPackageExports :: HscEnvEq -> IO ExportsMap
envImportPaths :: HscEnvEq -> Maybe (Set FilePath)
hscEnv :: HscEnvEq -> HscEnv
..}
    | Just Set FilePath
imps <- Maybe (Set FilePath)
envImportPaths
    = HscEnv
hscEnv{hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv){importPaths :: [FilePath]
importPaths = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
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 :: [FilePath]
importPaths = []}}

instance Show HscEnvEq where
  show :: HscEnvEq -> FilePath
show HscEnvEq{Unique
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
envUnique} = FilePath
"HscEnvEq " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
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 (Set FilePath)
d IO ExportsMap
_ IO (Maybe [ModuleName])
_) =
      -- deliberately skip the package exports map and visible module names
      Int -> ()
forall a. NFData a => a -> ()
rnf (Unique -> Int
hashUnique Unique
a) () -> () -> ()
`seq` HscEnv
b HscEnv -> () -> ()
`seq` [(InstalledUnitId, DynFlags)]
c [(InstalledUnitId, DynFlags)] -> () -> ()
`seq` Maybe (Set FilePath) -> ()
forall a. NFData a => a -> ()
rnf Maybe (Set FilePath)
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
_ = FilePath -> Put
forall a. HasCallStack => FilePath -> a
error FilePath
"not really"
  get :: Get HscEnvEq
get = FilePath -> Get HscEnvEq
forall a. HasCallStack => FilePath -> a
error FilePath
"not really"

-- | Given an action, produce a wrapped action that runs at most once.
--   The action is run in an async so it won't be killed by async exceptions
--   If the function raises an exception, the same exception will be reraised each time.
onceAsync :: IO a -> IO (IO a)
onceAsync :: IO a -> IO (IO a)
onceAsync IO a
act = do
    Var (Once a)
var <- Once a -> IO (Var (Once a))
forall a. a -> IO (Var a)
newVar Once a
forall a. Once a
OncePending
    let run :: Async c -> IO c
run Async c
as = (SomeException -> IO c)
-> (c -> IO c) -> IO (Either SomeException c) -> IO c
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM SomeException -> IO c
forall e a. Exception e => e -> IO a
throwIO c -> IO c
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async c -> IO (Either SomeException c)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async c
as)
    IO a -> IO (IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> IO (IO a) -> IO a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO a) -> IO a) -> IO (IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Var (Once a) -> (Once a -> IO (Once a, IO a)) -> IO (IO a)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Once a)
var ((Once a -> IO (Once a, IO a)) -> IO (IO a))
-> (Once a -> IO (Once a, IO a)) -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ \Once a
v -> case Once a
v of
        OnceRunning Async a
x -> (Once a, IO a) -> IO (Once a, IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Once a
v, IO a -> IO a
forall a. IO a -> IO a
unmask (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall c. Async c -> IO c
run Async a
x)
        Once a
OncePending -> do
            Async a
x <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO a
forall a. IO a -> IO a
unmask IO a
act)
            pure (Async a -> Once a
forall a. Async a -> Once a
OnceRunning Async a
x, IO a -> IO a
forall a. IO a -> IO a
unmask (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall c. Async c -> IO c
run Async a
x)

data Once a = OncePending | OnceRunning (Async a)