module Development.IDE.Types.HscEnvEq
( HscEnvEq,
hscEnv, newHscEnvEq,
hscEnvWithImportPaths,
newHscEnvEqPreserveImportPaths,
newHscEnvEqWithImportPaths,
updateHscEnvEq,
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 Data.Either (fromRight)
import Data.Set (Set)
import qualified Data.Set as Set
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 Ide.PluginUtils (toAbsolute)
import OpenTelemetry.Eventlog (withSpan)
import System.FilePath
data HscEnvEq = HscEnvEq
{ HscEnvEq -> Unique
envUnique :: !Unique
, HscEnvEq -> HscEnv
hscEnv :: !HscEnv
, HscEnvEq -> [(UnitId, DynFlags)]
deps :: [(UnitId, DynFlags)]
, HscEnvEq -> Maybe (Set FilePath)
envImportPaths :: Maybe (Set FilePath)
, HscEnvEq -> IO ExportsMap
envPackageExports :: IO ExportsMap
, HscEnvEq -> IO (Maybe [ModuleName])
envVisibleModuleNames :: IO (Maybe [ModuleName])
}
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
newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq :: FilePath
-> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq FilePath
root FilePath
cradlePath HscEnv
hscEnv0 [(UnitId, DynFlags)]
deps = do
let relativeToCradle :: FilePath -> FilePath
relativeToCradle = (FilePath -> FilePath
takeDirectory FilePath
cradlePath </>)
hscEnv :: HscEnv
hscEnv = HscEnv -> HscEnv
removeImportPaths HscEnv
hscEnv0
let importPathsCanon :: [FilePath]
importPathsCanon = FilePath -> FilePath -> FilePath
toAbsolute FilePath
root (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> [(UnitId, 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 [(UnitId, DynFlags)]
deps
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths :: Maybe (Set FilePath)
-> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe (Set FilePath)
envImportPaths HscEnv
hscEnv [(UnitId, DynFlags)]
deps = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
Unique
envUnique <- IO Unique
Unique.newUnique
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
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
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
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{[(UnitId, DynFlags)]
Maybe (Set FilePath)
IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
hscEnv :: HscEnv
envImportPaths :: Maybe (Set FilePath)
envPackageExports :: IO ExportsMap
envVisibleModuleNames :: IO (Maybe [ModuleName])
deps :: [(UnitId, DynFlags)]
envUnique :: Unique
envImportPaths :: Maybe (Set FilePath)
hscEnv :: HscEnv
deps :: [(UnitId, DynFlags)]
envUnique :: Unique
envPackageExports :: IO ExportsMap
envVisibleModuleNames :: IO (Maybe [ModuleName])
..}
newHscEnvEqPreserveImportPaths
:: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths = Maybe (Set FilePath)
-> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe (Set FilePath)
forall a. Maybe a
Nothing
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq{[(UnitId, DynFlags)]
Maybe (Set FilePath)
IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
hscEnv :: HscEnvEq -> HscEnv
envImportPaths :: HscEnvEq -> Maybe (Set FilePath)
envPackageExports :: HscEnvEq -> IO ExportsMap
envVisibleModuleNames :: HscEnvEq -> IO (Maybe [ModuleName])
deps :: HscEnvEq -> [(UnitId, DynFlags)]
envUnique :: HscEnvEq -> Unique
envUnique :: Unique
hscEnv :: HscEnv
deps :: [(UnitId, DynFlags)]
envImportPaths :: Maybe (Set FilePath)
envPackageExports :: IO ExportsMap
envVisibleModuleNames :: IO (Maybe [ModuleName])
..}
| Just Set FilePath
imps <- Maybe (Set FilePath)
envImportPaths
= DynFlags -> HscEnv -> HscEnv
hscSetFlags ([FilePath] -> DynFlags -> DynFlags
setImportPaths (Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
imps) (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv)) HscEnv
hscEnv
| Bool
otherwise
= HscEnv
hscEnv
removeImportPaths :: HscEnv -> HscEnv
removeImportPaths :: HscEnv -> HscEnv
removeImportPaths HscEnv
hsc = DynFlags -> HscEnv -> HscEnv
hscSetFlags ([FilePath] -> DynFlags -> DynFlags
setImportPaths [] (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc)) HscEnv
hsc
instance Show HscEnvEq where
show :: HscEnvEq -> FilePath
show HscEnvEq{Unique
envUnique :: HscEnvEq -> Unique
envUnique :: Unique
envUnique} = FilePath
"HscEnvEq " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
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 [(UnitId, DynFlags)]
c Maybe (Set FilePath)
d IO ExportsMap
_ IO (Maybe [ModuleName])
_) =
Int -> ()
forall a. NFData a => a -> ()
rnf (Unique -> Int
Unique.hashUnique Unique
a) () -> () -> ()
forall a b. a -> b -> b
`seq` HscEnv
b HscEnv -> () -> ()
forall a b. a -> b -> b
`seq` [(UnitId, DynFlags)]
c [(UnitId, DynFlags)] -> () -> ()
forall a b. a -> b -> b
`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
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)