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           OpenTelemetry.Eventlog          (withSpan)
import           System.Directory                (makeAbsolute)
import           System.FilePath

-- | 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 -> [(UnitId, DynFlags)]
deps                  :: [(UnitId, 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
    }

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 :: Unique
envUnique = Unique
newUnique, hscEnv :: HscEnv
hscEnv = HscEnv
newHscEnv }
  Unique -> HscEnvEq
update forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
Unique.newUnique

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

    -- Make Absolute since targets are also absolute
    [FilePath]
importPathsCanon <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
makeAbsolute forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
relativeToCradle 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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

    -- it's very important to delay the package exports computation
    IO ExportsMap
envPackageExports <- forall a. IO a -> IO (IO a)
onceAsync forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Package Exports" 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) <- forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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          -> 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 <- forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hscEnv forall a b. (a -> b) -> a -> b
$
                    forall lcl.
SDoc
-> GenModule Unit -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface SDoc
"" GenModule Unit
m (IsBootInterface -> WhereFrom
ImportByUser IsBootInterface
NotBoot)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case MaybeErr SDoc ModIface
modIface of
                    Maybes.Failed    SDoc
_r -> forall a. Maybe a
Nothing
                    Maybes.Succeeded ModIface
mi -> forall a. a -> Maybe a
Just ModIface
mi
        [ModIface]
modIfaces <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM GenModule Unit -> IO (Maybe ModIface)
doOne [GenModule Unit]
modules
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ModIface] -> ExportsMap
createExportsMap [ModIface]
modIfaces

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

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

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEqPreserveImportPaths
    :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths = Maybe (Set FilePath)
-> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths 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{[(UnitId, DynFlags)]
Maybe (Set FilePath)
IO (Maybe [ModuleName])
IO ExportsMap
Unique
HscEnv
envVisibleModuleNames :: IO (Maybe [ModuleName])
envPackageExports :: IO ExportsMap
envImportPaths :: Maybe (Set FilePath)
deps :: [(UnitId, DynFlags)]
hscEnv :: HscEnv
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
deps :: HscEnvEq -> [(UnitId, 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
    = DynFlags -> HscEnv -> HscEnv
hscSetFlags ([FilePath] -> DynFlags -> DynFlags
setImportPaths (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 :: Unique
envUnique :: HscEnvEq -> Unique
envUnique} = FilePath
"HscEnvEq " forall a. [a] -> [a] -> [a]
++ 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 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])
_) =
      -- deliberately skip the package exports map and visible module names
      forall a. NFData a => a -> ()
rnf (Unique -> Int
Unique.hashUnique Unique
a) seq :: forall a b. a -> b -> b
`seq` HscEnv
b seq :: forall a b. a -> b -> b
`seq` [(UnitId, DynFlags)]
c seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe (Set FilePath)
d

instance Hashable HscEnvEq where
  hashWithSalt :: Int -> HscEnvEq -> Int
hashWithSalt Int
s = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s 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 <- forall a. a -> IO (Var a)
newVar forall a. Once a
OncePending
    let run :: Async c -> IO c
run Async c
as = forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Async a -> IO (Either SomeException a)
waitCatch Async c
as)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Once a)
var forall a b. (a -> b) -> a -> b
$ \Once a
v -> case Once a
v of
        OnceRunning Async a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Once a
v, forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall {c}. Async c -> IO c
run Async a
x)
        Once a
OncePending -> do
            Async a
x <- forall a. IO a -> IO (Async a)
async (forall a. IO a -> IO a
unmask IO a
act)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Async a -> Once a
OnceRunning Async a
x, forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall {c}. Async c -> IO c
run Async a
x)

data Once a = OncePending | OnceRunning (Async a)