{-# LANGUAGE CPP #-}
module Development.IDE.Types.HscEnvEq
(   HscEnvEq,
    hscEnv, newHscEnvEq,
    updateHscEnvEq,
    envPackageExports,
    envVisibleModuleNames,
) where


import           Control.Concurrent.Async        (Async, async, waitCatch)
import           Control.Concurrent.Strict       (modifyVar, newVar)
import           Control.DeepSeq                 (force, rwhnf)
import           Control.Exception               (evaluate, mask, throwIO)
import           Control.Monad.Extra             (eitherM, join, mapMaybeM)
import           Data.Either                     (fromRight)
import           Data.IORef
import qualified Data.Map                        as M
import           Data.Unique                     (Unique)
import qualified Data.Unique                     as Unique
import           Development.IDE.GHC.Compat      hiding (newUnique)
import qualified Development.IDE.GHC.Compat.Util as Maybes
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           GHC.Driver.Env                  (hsc_all_home_unit_ids)
import           Ide.PluginUtils                 (toAbsolute)
import           OpenTelemetry.Eventlog          (withSpan)
import           System.Directory                (makeAbsolute)


-- | An 'HscEnv' with equality. Two values are considered equal
--   if they are created with the same call to 'newHscEnvEq' or
--   'updateHscEnvEq'.
data HscEnvEq = HscEnvEq
    { HscEnvEq -> Unique
envUnique             :: !Unique
    , HscEnvEq -> HscEnv
hscEnv                :: !HscEnv
    , 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
    }

updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq
updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq
updateHscEnvEq HscEnvEq
oldHscEnvEq HscEnv
newHscEnv = do
  let update :: Unique -> HscEnvEq
update Unique
newUnique = HscEnvEq
oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv }
  Unique -> HscEnvEq
update (Unique -> HscEnvEq) -> IO Unique -> IO HscEnvEq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
Unique.newUnique

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEq :: HscEnv -> IO HscEnvEq
newHscEnvEq :: HscEnv -> IO HscEnvEq
newHscEnvEq HscEnv
hscEnv' = do

    IORef (InstalledModuleEnv Any)
mod_cache <- InstalledModuleEnv Any -> IO (IORef (InstalledModuleEnv Any))
forall a. a -> IO (IORef a)
newIORef InstalledModuleEnv Any
forall a. InstalledModuleEnv a
emptyInstalledModuleEnv
    IORef (Map Any Any)
file_cache <- Map Any Any -> IO (IORef (Map Any Any))
forall a. a -> IO (IORef a)
newIORef Map Any Any
forall k a. Map k a
M.empty
    -- This finder cache is for things which are outside of things which are tracked
    -- by HLS. For example, non-home modules, dependent object files etc
#if MIN_VERSION_ghc(9,11,0)
    let hscEnv = hscEnv'
               { hsc_FC = FinderCache
                        { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver"
                        , addToFinderCache  = \(GWIB im _) val -> do
                            if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'
                            then error "tried to add home module to FC"
                            else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ())
                        , lookupFinderCache = \(GWIB im _) -> do
                            if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'
                            then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv')))
                            else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im
                        , lookupFileCache = \fp -> error ("not used by HLS" ++ fp)
                        }
                }

#else
    let hscEnv :: HscEnv
hscEnv = HscEnv
hscEnv'
#endif

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

    Unique
envUnique <- IO Unique
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 :: UnitState
pkgst   = HscEnv -> UnitState
unitState HscEnv
hscEnv
            depends :: [Unit]
depends = UnitState -> [Unit]
explicitUnits UnitState
pkgst
            modules :: [GenModule Unit]
modules =
                [ GenModule Unit
m
                | Unit
d        <- [Unit]
depends
                , Just UnitInfo
pkg <- [Unit -> HscEnv -> Maybe UnitInfo
lookupPackageConfig Unit
d HscEnv
hscEnv]
                , (ModuleName
modName, Maybe (GenModule Unit)
maybeOtherPkgMod) <- UnitInfo -> [(ModuleName, Maybe (GenModule Unit))]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
                , let m :: GenModule Unit
m = case Maybe (GenModule Unit)
maybeOtherPkgMod of
                        -- When module is re-exported from another package,
                        -- the origin module is represented by value in Just
                        Just GenModule Unit
otherPkgMod -> GenModule Unit
otherPkgMod
                        Maybe (GenModule Unit)
Nothing          -> Unit -> ModuleName -> GenModule Unit
forall u. u -> ModuleName -> GenModule u
mkModule (UnitInfo -> Unit
mkUnit UnitInfo
pkg) ModuleName
modName
                ]

            doOne :: GenModule Unit -> IO (Maybe ModIface)
doOne GenModule Unit
m = do
                MaybeErr SDoc ModIface
modIface <- HscEnv
-> IfG (MaybeErr SDoc ModIface) -> IO (MaybeErr SDoc ModIface)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hscEnv (IfG (MaybeErr SDoc ModIface) -> IO (MaybeErr SDoc ModIface))
-> IfG (MaybeErr SDoc ModIface) -> IO (MaybeErr SDoc ModIface)
forall a b. (a -> b) -> a -> b
$
                    SDoc -> GenModule Unit -> WhereFrom -> IfG (MaybeErr SDoc ModIface)
forall lcl.
SDoc
-> GenModule Unit -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface SDoc
"" GenModule Unit
m (IsBootInterface -> WhereFrom
ImportByUser IsBootInterface
NotBoot)
                Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModIface -> IO (Maybe ModIface))
-> Maybe ModIface -> IO (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ case MaybeErr SDoc ModIface
modIface of
                    Maybes.Failed    SDoc
_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 <- (GenModule Unit -> IO (Maybe ModIface))
-> [GenModule Unit] -> IO [ModIface]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM GenModule Unit -> IO (Maybe ModIface)
doOne [GenModule Unit]
modules
        ExportsMap -> IO ExportsMap
forall a. a -> IO a
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

    -- 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
$ HscEnv -> [ModuleName]
listVisibleModuleNames HscEnv
hscEnv)

    HscEnvEq -> IO HscEnvEq
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnvEq{IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
hscEnv :: HscEnv
envPackageExports :: IO ExportsMap
envVisibleModuleNames :: IO (Maybe [ModuleName])
envUnique :: Unique
hscEnv :: HscEnv
envUnique :: Unique
envPackageExports :: IO ExportsMap
envVisibleModuleNames :: IO (Maybe [ModuleName])
..}

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

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

instance NFData HscEnvEq where
  rnf :: HscEnvEq -> ()
rnf (HscEnvEq Unique
a HscEnv
b IO ExportsMap
_ IO (Maybe [ModuleName])
_) =
      -- deliberately skip the package exports map and visible module names
      Int -> ()
forall a. NFData a => a -> ()
rnf (Unique -> Int
Unique.hashUnique Unique
a) () -> () -> ()
forall a b. a -> b -> b
`seq` HscEnv -> ()
forall a. a -> ()
rwhnf HscEnv
b

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

-- | 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 :: forall a. 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 a. a -> IO a
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 a. a -> 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 a. 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)
            (Once a, IO a) -> IO (Once a, IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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)