{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TypeFamilies              #-}

{-|
The logic for setting up a ghcide session by tapping into hie-bios.
-}
module Development.IDE.Session
  (SessionLoadingOptions(..)
  ,CacheDirs(..)
  ,loadSession
  ,loadSessionWithOptions
  ,setInitialDynFlags
  ,getHieDbLoc
  ,runWithDb
  ,retryOnSqliteBusy
  ,retryOnException
  ,Log(..)
  ) where

-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
-- the real GHC library and the types are incompatible. Furthermore, when
-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!

import           Control.Concurrent.Async
import           Control.Concurrent.Strict
import           Control.Exception.Safe               as Safe
import           Control.Monad
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import qualified Crypto.Hash.SHA1                     as H
import           Data.Aeson                           hiding (Error)
import           Data.Bifunctor
import qualified Data.ByteString.Base16               as B16
import qualified Data.ByteString.Char8                as B
import           Data.Default
import           Data.Either.Extra
import           Data.Function
import           Data.Hashable                        hiding (hash)
import qualified Data.HashMap.Strict                  as HM
import           Data.IORef
import           Data.List
import           Data.List.Extra                      as L
import           Data.List.NonEmpty                   (NonEmpty (..))
import qualified Data.List.NonEmpty                   as NE
import qualified Data.Map.Strict                      as Map
import           Data.Maybe
import           Data.Proxy
import qualified Data.Text                            as T
import           Data.Time.Clock
import           Data.Version
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake           hiding (Log, Priority,
                                                       knownTargets, withHieDb)
import qualified Development.IDE.GHC.Compat           as Compat
import           Development.IDE.GHC.Compat.Core      hiding (Target,
                                                       TargetFile, TargetModule,
                                                       Var, Warning, getOptions)
import qualified Development.IDE.GHC.Compat.Core      as GHC
import           Development.IDE.GHC.Compat.Env       hiding (Logger)
import           Development.IDE.GHC.Compat.Units     (UnitId)
import           Development.IDE.GHC.Util
import           Development.IDE.Graph                (Action)
import           Development.IDE.Session.VersionCheck
import           Development.IDE.Types.Diagnostics
import           Development.IDE.Types.Exports
import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,
                                                       newHscEnvEqPreserveImportPaths)
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import           GHC.Check
import qualified HIE.Bios                             as HieBios
import           HIE.Bios.Environment                 hiding (getCacheDir)
import           HIE.Bios.Types                       hiding (Log)
import qualified HIE.Bios.Types                       as HieBios
import           Ide.Logger                           (Pretty (pretty),
                                                       Priority (Debug, Error, Info, Warning),
                                                       Recorder, WithPriority,
                                                       cmapWithPrio, logWith,
                                                       nest,
                                                       toCologActionWithPrio,
                                                       vcat, viaShow, (<+>))
import           Language.LSP.Protocol.Message
import           Language.LSP.Server
import           System.Directory
import qualified System.Directory.Extra               as IO
import           System.FilePath
import           System.Info

import           Control.Applicative                  (Alternative ((<|>)))
import           Data.Void

import           Control.Concurrent.STM.Stats         (atomically, modifyTVar',
                                                       readTVar, writeTVar)
import           Control.Concurrent.STM.TQueue
import           Control.DeepSeq
import           Control.Exception                    (evaluate)
import           Control.Monad.IO.Unlift              (MonadUnliftIO)
import           Data.Foldable                        (for_)
import           Data.HashMap.Strict                  (HashMap)
import           Data.HashSet                         (HashSet)
import qualified Data.HashSet                         as Set
import           Database.SQLite.Simple
import           Development.IDE.Core.Tracing         (withTrace)
import           Development.IDE.Session.Diagnostics  (renderCradleError)
import           Development.IDE.Types.Shake          (WithHieDb)
import           HieDb.Create
import           HieDb.Types
import           HieDb.Utils
import qualified System.Random                        as Random
import           System.Random                        (RandomGen)

import qualified Development.IDE.Session.Implicit     as GhcIde

import           Development.IDE.GHC.Compat.CmdLine


-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
#if MIN_VERSION_ghc(9,3,0)
import qualified Data.Set                             as OS

import           GHC.Data.Bag
import           GHC.Driver.Env                       (hsc_all_home_unit_ids)
import           GHC.Driver.Errors.Types
import           GHC.Driver.Make                      (checkHomeUnitsClosed)
import           GHC.Types.Error                      (errMsgDiagnostic)
import           GHC.Unit.State
#endif

import           GHC.ResponseFile

data Log
  = LogSettingInitialDynFlags
  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)
  | LogGetInitialGhcLibDirDefaultCradleNone
  | LogHieDbRetry !Int !Int !Int !SomeException
  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException
  | LogHieDbWriterThreadSQLiteError !SQLError
  | LogHieDbWriterThreadException !SomeException
  | LogInterfaceFilesCacheDir !FilePath
  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))
  | LogMakingNewHscEnv ![UnitId]
  | LogDLLLoadError !String
  | LogCradlePath !FilePath
  | LogCradleNotFound !FilePath
  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath))
  | LogCradle !(Cradle Void)
  | LogNoneCradleFound FilePath
  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
  | LogHieBios HieBios.Log
deriving instance Show Log

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogNoneCradleFound String
path ->
      Doc ann
"None cradle found for" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
", ignoring the file"
    Log
LogSettingInitialDynFlags ->
      Doc ann
"Setting initial dynflags..."
    LogGetInitialGhcLibDirDefaultCradleFail CradleError
cradleError String
rootDirPath Maybe String
hieYamlPath Cradle Void
cradle ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"Couldn't load cradle for ghc libdir."
          , Doc ann
"Cradle error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CradleError -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow CradleError
cradleError
          , Doc ann
"Root dir path:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
rootDirPath
          , Doc ann
"hie.yaml path:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe String -> Doc ann
forall ann. Maybe String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe String
hieYamlPath
          , Doc ann
"Cradle:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Cradle Void -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Cradle Void
cradle ]
    Log
LogGetInitialGhcLibDirDefaultCradleNone ->
      Doc ann
"Couldn't load cradle. Cradle not found."
    LogHieDbRetry Int
delay Int
maxDelay Int
retriesRemaining SomeException
e ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"Retrying hiedb action..."
          , Doc ann
"delay:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
delay
          , Doc ann
"maximum delay:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
maxDelay
          , Doc ann
"retries remaining:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
retriesRemaining
          , Doc ann
"SQLite error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e) ]
    LogHieDbRetriesExhausted Int
baseDelay Int
maxDelay Int
retriesRemaining SomeException
e ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"Retries exhausted for hiedb action."
          , Doc ann
"base delay:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
baseDelay
          , Doc ann
"maximum delay:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
maxDelay
          , Doc ann
"retries remaining:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
retriesRemaining
          , Doc ann
"Exception:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e) ]
    LogHieDbWriterThreadSQLiteError SQLError
e ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"HieDb writer thread SQLite error:"
          , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SQLError -> String
forall e. Exception e => e -> String
displayException SQLError
e) ]
    LogHieDbWriterThreadException SomeException
e ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"HieDb writer thread exception:"
          , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e) ]
    LogInterfaceFilesCacheDir String
path ->
      Doc ann
"Interface files cache directory:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path
    LogKnownFilesUpdated HashMap Target (HashSet NormalizedFilePath)
targetToPathsMap ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"Known files updated:"
          , HashMap Target (HashSet String) -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (HashMap Target (HashSet String) -> Doc ann)
-> HashMap Target (HashSet String) -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((HashSet NormalizedFilePath -> HashSet String)
-> HashMap Target (HashSet NormalizedFilePath)
-> HashMap Target (HashSet String)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map ((HashSet NormalizedFilePath -> HashSet String)
 -> HashMap Target (HashSet NormalizedFilePath)
 -> HashMap Target (HashSet String))
-> ((NormalizedFilePath -> String)
    -> HashSet NormalizedFilePath -> HashSet String)
-> (NormalizedFilePath -> String)
-> HashMap Target (HashSet NormalizedFilePath)
-> HashMap Target (HashSet String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormalizedFilePath -> String)
-> HashSet NormalizedFilePath -> HashSet String
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
Set.map) NormalizedFilePath -> String
fromNormalizedFilePath HashMap Target (HashSet NormalizedFilePath)
targetToPathsMap
          ]
    LogMakingNewHscEnv [UnitId]
inPlaceUnitIds ->
      Doc ann
"Making new HscEnv. In-place unit ids:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> Doc ann
forall ann. [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Show a => a -> String
show [UnitId]
inPlaceUnitIds)
    LogDLLLoadError String
errorString ->
      Doc ann
"Error dynamically loading libm.so.6:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
errorString
    LogCradlePath String
path ->
      Doc ann
"Cradle path:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path
    LogCradleNotFound String
path ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
        , Doc ann
"Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."
        , Doc ann
"You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]
    LogSessionLoadingResult Either [CradleError] (ComponentOptions, String)
e ->
      Doc ann
"Session loading result:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Either [CradleError] (ComponentOptions, String) -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Either [CradleError] (ComponentOptions, String)
e
    LogCradle Cradle Void
cradle ->
      Doc ann
"Cradle:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Cradle Void -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Cradle Void
cradle
    LogNewComponentCache (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
componentCache ->
      Doc ann
"New component cache HscEnvEq:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
componentCache
    LogHieBios Log
msg -> Log -> Doc ann
forall ann. Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Log
msg

-- | Bump this version number when making changes to the format of the data stored in hiedb
hiedbDataVersion :: String
hiedbDataVersion :: String
hiedbDataVersion = String
"1"

data CacheDirs = CacheDirs
  { CacheDirs -> Maybe String
hiCacheDir, CacheDirs -> Maybe String
hieCacheDir, CacheDirs -> Maybe String
oCacheDir :: Maybe FilePath}

data SessionLoadingOptions = SessionLoadingOptions
  { SessionLoadingOptions -> String -> IO (Maybe String)
findCradle             :: FilePath -> IO (Maybe FilePath)
  -- | Load the cradle with an optional 'hie.yaml' location.
  -- If a 'hie.yaml' is given, use it to load the cradle.
  -- Otherwise, use the provided project root directory to determine the cradle type.
  , SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
loadCradle             :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
  -- | Given the project name and a set of command line flags,
  --   return the path for storing generated GHC artifacts,
  --   or 'Nothing' to respect the cradle setting
  , SessionLoadingOptions -> String -> [String] -> IO CacheDirs
getCacheDirs           :: String -> [String] -> IO CacheDirs
  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
  , SessionLoadingOptions
-> Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)
#if !MIN_VERSION_ghc(9,3,0)
  , fakeUid                :: UnitId
    -- ^ unit id used to tag the internal component built by ghcide
    --   To reuse external interface files the unit ids must match,
    --   thus make sure to build them with `--this-unit-id` set to the
    --   same value as the ghcide fake uid
#endif
  }

instance Default SessionLoadingOptions where
    def :: SessionLoadingOptions
def =  SessionLoadingOptions
        {findCradle :: String -> IO (Maybe String)
findCradle = String -> IO (Maybe String)
HieBios.findCradle
        ,loadCradle :: Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
loadCradle = Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
loadWithImplicitCradle
        ,getCacheDirs :: String -> [String] -> IO CacheDirs
getCacheDirs = String -> [String] -> IO CacheDirs
getCacheDirsDefault
        ,getInitialGhcLibDir :: Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
getInitialGhcLibDir = Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
getInitialGhcLibDirDefault
#if !MIN_VERSION_ghc(9,3,0)
        ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main")
#endif
        }

-- | Find the cradle for a given 'hie.yaml' configuration.
--
-- If a 'hie.yaml' is given, the cradle is read from the config.
--  If this config does not comply to the "hie.yaml"
-- specification, an error is raised.
--
-- If no location for "hie.yaml" is provided, the implicit config is used
-- using the provided root directory for discovering the project.
-- The implicit config uses different heuristics to determine the type
-- of the project that may or may not be accurate.
loadWithImplicitCradle
  :: Recorder (WithPriority Log)
  -> Maybe FilePath
  -- ^ Optional 'hie.yaml' location. Will be used if given.
  -> FilePath
  -- ^ Root directory of the project. Required as a fallback
  -- if no 'hie.yaml' location is given.
  -> IO (HieBios.Cradle Void)
loadWithImplicitCradle :: Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
loadWithImplicitCradle Recorder (WithPriority Log)
recorder Maybe String
mHieYaml String
rootDir = do
  let logger :: LogAction IO (WithSeverity Log)
logger = Recorder (WithPriority Log) -> LogAction IO (WithSeverity Log)
forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogHieBios Recorder (WithPriority Log)
recorder)
  case Maybe String
mHieYaml of
    Just String
yaml -> LogAction IO (WithSeverity Log) -> String -> IO (Cradle Void)
HieBios.loadCradle LogAction IO (WithSeverity Log)
logger String
yaml
    Maybe String
Nothing   -> LogAction IO (WithSeverity Log) -> String -> IO (Cradle Void)
forall a.
Show a =>
LogAction IO (WithSeverity Log) -> String -> IO (Cradle a)
GhcIde.loadImplicitCradle LogAction IO (WithSeverity Log)
logger String
rootDir

getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)
getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
getInitialGhcLibDirDefault Recorder (WithPriority Log)
recorder String
rootDir = do
  Maybe String
hieYaml <- SessionLoadingOptions -> String -> IO (Maybe String)
findCradle SessionLoadingOptions
forall a. Default a => a
def (String
rootDir String -> ShowS
</> String
"a")
  Cradle Void
cradle <- SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
loadCradle SessionLoadingOptions
forall a. Default a => a
def Recorder (WithPriority Log)
recorder Maybe String
hieYaml String
rootDir
  CradleLoadResult String
libDirRes <- Cradle Void -> IO (CradleLoadResult String)
forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcLibDir Cradle Void
cradle
  case CradleLoadResult String
libDirRes of
      CradleSuccess String
libdir -> Maybe LibDir -> IO (Maybe LibDir)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LibDir -> IO (Maybe LibDir))
-> Maybe LibDir -> IO (Maybe LibDir)
forall a b. (a -> b) -> a -> b
$ LibDir -> Maybe LibDir
forall a. a -> Maybe a
Just (LibDir -> Maybe LibDir) -> LibDir -> Maybe LibDir
forall a b. (a -> b) -> a -> b
$ String -> LibDir
LibDir String
libdir
      CradleFail CradleError
err -> do
        Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ CradleError -> String -> Maybe String -> Cradle Void -> Log
LogGetInitialGhcLibDirDefaultCradleFail CradleError
err String
rootDir Maybe String
hieYaml Cradle Void
cradle
        Maybe LibDir -> IO (Maybe LibDir)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
forall a. Maybe a
Nothing
      CradleLoadResult String
CradleNone -> do
        Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning Log
LogGetInitialGhcLibDirDefaultCradleNone
        Maybe LibDir -> IO (Maybe LibDir)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
forall a. Maybe a
Nothing

-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags :: Recorder (WithPriority Log)
-> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags Recorder (WithPriority Log)
recorder String
rootDir SessionLoadingOptions{String -> IO (Maybe String)
String -> [String] -> IO CacheDirs
Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
findCradle :: SessionLoadingOptions -> String -> IO (Maybe String)
loadCradle :: SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
getCacheDirs :: SessionLoadingOptions -> String -> [String] -> IO CacheDirs
getInitialGhcLibDir :: SessionLoadingOptions
-> Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
findCradle :: String -> IO (Maybe String)
loadCradle :: Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
getCacheDirs :: String -> [String] -> IO CacheDirs
getInitialGhcLibDir :: Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
..} = do
  Maybe LibDir
libdir <- Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
getInitialGhcLibDir Recorder (WithPriority Log)
recorder String
rootDir
  Maybe DynFlags
dynFlags <- (LibDir -> IO DynFlags) -> Maybe LibDir -> IO (Maybe DynFlags)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM LibDir -> IO DynFlags
dynFlagsForPrinting Maybe LibDir
libdir
  Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug Log
LogSettingInitialDynFlags
  (DynFlags -> IO ()) -> Maybe DynFlags -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DynFlags -> IO ()
setUnsafeGlobalDynFlags Maybe DynFlags
dynFlags
  Maybe LibDir -> IO (Maybe LibDir)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
libdir

-- | If the action throws exception that satisfies predicate then we sleep for
-- a duration determined by the random exponential backoff formula,
-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try
-- the action again for a maximum of `maxRetryCount` times.
-- `MonadIO`, `MonadCatch` are used as constraints because there are a few
-- HieDb functions that don't return IO values.
retryOnException
  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)
  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just
  -> Recorder (WithPriority Log)
  -> Int -- ^ maximum backoff delay in microseconds
  -> Int -- ^ base backoff delay in microseconds
  -> Int -- ^ maximum number of times to retry
  -> g -- ^ random number generator
  -> m a -- ^ action that may throw exception
  -> m a
retryOnException :: forall (m :: * -> *) g e a.
(MonadIO m, MonadCatch m, RandomGen g, Exception e) =>
(e -> Maybe e)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> m a
retryOnException e -> Maybe e
exceptionPred Recorder (WithPriority Log)
recorder Int
maxDelay !Int
baseDelay !Int
maxTimesRetry g
rng m a
action = do
  Either e a
result <- (e -> Maybe e) -> m a -> m (Either e a)
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust e -> Maybe e
exceptionPred m a
action
  case Either e a
result of
    Left e
e
      | Int
maxTimesRetry Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
        -- multiply by 2 because baseDelay is midpoint of uniform range
        let newBaseDelay :: Int
newBaseDelay = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxDelay (Int
baseDelay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
        let (Int
delay, g
newRng) = (Int, Int) -> g -> (Int, g)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Int
0, Int
newBaseDelay) g
rng
        let newMaxTimesRetry :: Int
newMaxTimesRetry = Int
maxTimesRetry Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> SomeException -> Log
LogHieDbRetry Int
delay Int
maxDelay Int
newMaxTimesRetry (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)
          Int -> IO ()
threadDelay Int
delay
        (e -> Maybe e)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> m a
forall (m :: * -> *) g e a.
(MonadIO m, MonadCatch m, RandomGen g, Exception e) =>
(e -> Maybe e)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> m a
retryOnException e -> Maybe e
exceptionPred Recorder (WithPriority Log)
recorder Int
maxDelay Int
newBaseDelay Int
newMaxTimesRetry g
newRng m a
action

      | Bool
otherwise -> do
        IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
          Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> SomeException -> Log
LogHieDbRetriesExhausted Int
baseDelay Int
maxDelay Int
maxTimesRetry (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)
          e -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO e
e

    Right a
b -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b

-- | in microseconds
oneSecond :: Int
oneSecond :: Int
oneSecond = Int
1000000

-- | in microseconds
oneMillisecond :: Int
oneMillisecond :: Int
oneMillisecond = Int
1000

-- | default maximum number of times to retry hiedb call
maxRetryCount :: Int
maxRetryCount :: Int
maxRetryCount = Int
10

retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)
                  => Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy :: forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy Recorder (WithPriority Log)
recorder g
rng m a
action =
  let isErrorBusy :: SQLError -> Maybe SQLError
isErrorBusy SQLError
e
        | SQLError{ sqlError :: SQLError -> Error
sqlError = Error
ErrorBusy } <- SQLError
e = SQLError -> Maybe SQLError
forall a. a -> Maybe a
Just SQLError
e
        | Bool
otherwise = Maybe SQLError
forall a. Maybe a
Nothing
  in
    (SQLError -> Maybe SQLError)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> m a
forall (m :: * -> *) g e a.
(MonadIO m, MonadCatch m, RandomGen g, Exception e) =>
(e -> Maybe e)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> m a
retryOnException SQLError -> Maybe SQLError
isErrorBusy Recorder (WithPriority Log)
recorder Int
oneSecond Int
oneMillisecond Int
maxRetryCount g
rng m a
action

makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb
makeWithHieDbRetryable :: forall g.
RandomGen g =>
Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb
makeWithHieDbRetryable Recorder (WithPriority Log)
recorder g
rng HieDb
hieDb HieDb -> IO a
f =
  Recorder (WithPriority Log) -> g -> IO a -> IO a
forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy Recorder (WithPriority Log)
recorder g
rng (HieDb -> IO a
f HieDb
hieDb)

-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
-- by a worker thread using a dedicated database connection.
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb :: Recorder (WithPriority Log)
-> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb Recorder (WithPriority Log)
recorder String
fp WithHieDb -> IndexQueue -> IO ()
k = do
  -- use non-deterministic seed because maybe multiple HLS start at same time
  -- and send bursts of requests
  StdGen
rng <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
Random.newStdGen
  -- Delete the database if it has an incompatible schema version
  Recorder (WithPriority Log) -> StdGen -> IO () -> IO ()
forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy
    Recorder (WithPriority Log)
recorder
    StdGen
rng
    (String -> (HieDb -> IO ()) -> IO ()
forall a. String -> (HieDb -> IO a) -> IO a
withHieDb String
fp (IO () -> HieDb -> IO ()
forall a b. a -> b -> a
const (IO () -> HieDb -> IO ()) -> IO () -> HieDb -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO () -> (HieDbException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Safe.catch` \IncompatibleSchemaVersion{} -> String -> IO ()
removeFile String
fp)

  String -> (HieDb -> IO ()) -> IO ()
forall a. String -> (HieDb -> IO a) -> IO a
withHieDb String
fp ((HieDb -> IO ()) -> IO ()) -> (HieDb -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HieDb
writedb -> do
    -- the type signature is necessary to avoid concretizing the tyvar
    -- e.g. `withWriteDbRetryable initConn` without type signature will
    -- instantiate tyvar `a` to `()`
    let withWriteDbRetryable :: WithHieDb
        withWriteDbRetryable :: WithHieDb
withWriteDbRetryable = Recorder (WithPriority Log) -> StdGen -> HieDb -> WithHieDb
forall g.
RandomGen g =>
Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb
makeWithHieDbRetryable Recorder (WithPriority Log)
recorder StdGen
rng HieDb
writedb
    (HieDb -> IO ()) -> IO ()
WithHieDb
withWriteDbRetryable HieDb -> IO ()
initConn

    IndexQueue
chan <- IO IndexQueue
forall a. IO (TQueue a)
newTQueueIO

    IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (WithHieDb -> IndexQueue -> IO ()
writerThread (HieDb -> IO a) -> IO a
WithHieDb
withWriteDbRetryable IndexQueue
chan) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> do
      String -> (HieDb -> IO ()) -> IO ()
forall a. String -> (HieDb -> IO a) -> IO a
withHieDb String
fp (\HieDb
readDb -> WithHieDb -> IndexQueue -> IO ()
k (Recorder (WithPriority Log) -> StdGen -> HieDb -> WithHieDb
forall g.
RandomGen g =>
Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb
makeWithHieDbRetryable Recorder (WithPriority Log)
recorder StdGen
rng HieDb
readDb) IndexQueue
chan)
  where
    writerThread :: WithHieDb -> IndexQueue -> IO ()
    writerThread :: WithHieDb -> IndexQueue -> IO ()
writerThread WithHieDb
withHieDbRetryable IndexQueue
chan = do
      -- Clear the index of any files that might have been deleted since the last run
      ()
_ <- (HieDb -> IO ()) -> IO ()
WithHieDb
withHieDbRetryable HieDb -> IO ()
deleteMissingRealFiles
      Int
_ <- (HieDb -> IO Int) -> IO Int
WithHieDb
withHieDbRetryable HieDb -> IO Int
garbageCollectTypeNames
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ((HieDb -> IO ()) -> IO ()) -> IO ()
l <- STM (((HieDb -> IO ()) -> IO ()) -> IO ())
-> IO (((HieDb -> IO ()) -> IO ()) -> IO ())
forall a. STM a -> IO a
atomically (STM (((HieDb -> IO ()) -> IO ()) -> IO ())
 -> IO (((HieDb -> IO ()) -> IO ()) -> IO ()))
-> STM (((HieDb -> IO ()) -> IO ()) -> IO ())
-> IO (((HieDb -> IO ()) -> IO ()) -> IO ())
forall a b. (a -> b) -> a -> b
$ IndexQueue -> STM (((HieDb -> IO ()) -> IO ()) -> IO ())
forall a. TQueue a -> STM a
readTQueue IndexQueue
chan
        -- TODO: probably should let exceptions be caught/logged/handled by top level handler
        ((HieDb -> IO ()) -> IO ()) -> IO ()
l (HieDb -> IO ()) -> IO ()
WithHieDb
withHieDbRetryable
          IO () -> (SQLError -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Safe.catch` \e :: SQLError
e@SQLError{} -> do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SQLError -> Log
LogHieDbWriterThreadSQLiteError SQLError
e
          IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`Safe.catchAny` \SomeException
f -> do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogHieDbWriterThreadException SomeException
f


getHieDbLoc :: FilePath -> IO FilePath
getHieDbLoc :: String -> IO String
getHieDbLoc String
dir = do
  let db :: String
db = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
dirHash, ShowS
takeBaseName String
dir, String
Compat.ghcVersionStr, String
hiedbDataVersion] String -> ShowS
<.> String
"hiedb"
      dirHash :: String
dirHash = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
H.hash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
dir
  String
cDir <- XdgDirectory -> String -> IO String
IO.getXdgDirectory XdgDirectory
IO.XdgCache String
cacheDir
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cDir
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
cDir String -> ShowS
</> String
db)

-- | Given a root directory, return a Shake 'Action' which setups an
-- 'IdeGhcSession' given a file.
-- Some of the many things this does:
--
-- * Find the cradle for the file
-- * Get the session options,
-- * Get the GHC lib directory
-- * Make sure the GHC compiletime and runtime versions match
-- * Restart the Shake session
--
-- This is the key function which implements multi-component support. All
-- components mapping to the same hie.yaml file are mapped to the same
-- HscEnv which is updated as new components are discovered.
loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)
loadSession :: Recorder (WithPriority Log) -> String -> IO (Action IdeGhcSession)
loadSession Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions Recorder (WithPriority Log)
recorder SessionLoadingOptions
forall a. Default a => a
def

loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
loadSessionWithOptions :: Recorder (WithPriority Log)
-> SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions Recorder (WithPriority Log)
recorder SessionLoadingOptions{String -> IO (Maybe String)
String -> [String] -> IO CacheDirs
Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
findCradle :: SessionLoadingOptions -> String -> IO (Maybe String)
loadCradle :: SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
getCacheDirs :: SessionLoadingOptions -> String -> [String] -> IO CacheDirs
getInitialGhcLibDir :: SessionLoadingOptions
-> Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
findCradle :: String -> IO (Maybe String)
loadCradle :: Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
getCacheDirs :: String -> [String] -> IO CacheDirs
getInitialGhcLibDir :: Recorder (WithPriority Log) -> String -> IO (Maybe LibDir)
..} String
dir = do
  IORef [String]
cradle_files <- [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
  Var HieMap
hscEnvs <- HieMap -> IO (Var HieMap)
forall a. a -> IO (Var a)
newVar HieMap
forall k a. Map k a
Map.empty :: IO (Var HieMap)
  -- Mapping from a Filepath to HscEnv
  Var FlagsMap
fileToFlags <- FlagsMap -> IO (Var FlagsMap)
forall a. a -> IO (Var a)
newVar FlagsMap
forall k a. Map k a
Map.empty :: IO (Var FlagsMap)
  -- Mapping from a Filepath to its 'hie.yaml' location.
  -- Should hold the same Filepaths as 'fileToFlags', otherwise
  -- they are inconsistent. So, everywhere you modify 'fileToFlags',
  -- you have to modify 'filesMap' as well.
  Var FilesMap
filesMap <- FilesMap -> IO (Var FilesMap)
forall a. a -> IO (Var a)
newVar FilesMap
forall k v. HashMap k v
HM.empty :: IO (Var FilesMap)
  -- Version of the mappings above
  Var Int
version <- Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar Int
0
  let returnWithVersion :: (String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> Action IdeGhcSession
returnWithVersion String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
fun = (String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> Int -> IdeGhcSession
IdeGhcSession String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
fun (Int -> IdeGhcSession) -> Action Int -> Action IdeGhcSession
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> Action Int
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Var Int -> IO Int
forall a. Var a -> IO a
readVar Var Int
version)
  -- This caches the mapping from Mod.hs -> hie.yaml
  String -> IO (Maybe String)
cradleLoc <- IO (String -> IO (Maybe String))
-> IO (String -> IO (Maybe String))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String -> IO (Maybe String))
 -> IO (String -> IO (Maybe String)))
-> IO (String -> IO (Maybe String))
-> IO (String -> IO (Maybe String))
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe String)) -> IO (String -> IO (Maybe String))
forall a b. Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO ((String -> IO (Maybe String)) -> IO (String -> IO (Maybe String)))
-> (String -> IO (Maybe String))
-> IO (String -> IO (Maybe String))
forall a b. (a -> b) -> a -> b
$ \String
v -> do
      Maybe String
res <- String -> IO (Maybe String)
findCradle String
v
      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
      -- try and normalise that
      -- e.g. see https://github.com/haskell/ghcide/issues/126
      Maybe String
res' <- (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse String -> IO String
makeAbsolute Maybe String
res
      Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ ShowS
normalise ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
res'

  Async (([FileDiagnostic], Maybe HscEnvEq), [String])
dummyAs <- IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a. IO a -> IO (Async a)
async (IO (([FileDiagnostic], Maybe HscEnvEq), [String])
 -> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a b. (a -> b) -> a -> b
$ (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. HasCallStack => String -> a
error String
"Uninitialised")
  Var (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
runningCradle <- Async (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (Var (Async (([FileDiagnostic], Maybe HscEnvEq), [String])))
forall a. a -> IO (Var a)
newVar Async (([FileDiagnostic], Maybe HscEnvEq), [String])
dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))

  Action IdeGhcSession -> IO (Action IdeGhcSession)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Action IdeGhcSession -> IO (Action IdeGhcSession))
-> Action IdeGhcSession -> IO (Action IdeGhcSession)
forall a b. (a -> b) -> a -> b
$ do
    extras :: ShakeExtras
extras@ShakeExtras{VFSModified -> String -> [DelayedAction ()] -> IO ()
restartShakeSession :: VFSModified -> String -> [DelayedAction ()] -> IO ()
$sel:restartShakeSession:ShakeExtras :: ShakeExtras -> VFSModified -> String -> [DelayedAction ()] -> IO ()
restartShakeSession, NameCache
ideNc :: NameCache
$sel:ideNc:ShakeExtras :: ShakeExtras -> NameCache
ideNc, TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar :: TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras
-> TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar, Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv
                      } <- Action ShakeExtras
getShakeExtras
    let invalidateShakeCache :: IO ()
        invalidateShakeCache :: IO ()
invalidateShakeCache = do
            IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Int -> (Int -> Int) -> IO Int
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var Int
version Int -> Int
forall a. Enum a => a -> a
succ
            IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> GhcSessionIO -> [NormalizedFilePath] -> STM (IO ())
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys ShakeExtras
extras GhcSessionIO
GhcSessionIO [NormalizedFilePath
emptyFilePath]

    IdeOptions{ optTesting :: IdeOptions -> IdeTesting
optTesting = IdeTesting Bool
optTesting
              , optCheckProject :: IdeOptions -> IO Bool
optCheckProject = IO Bool
getCheckProject
              , [String]
optExtensions :: [String]
optExtensions :: IdeOptions -> [String]
optExtensions
              } <- Action IdeOptions
getIdeOptions

        -- populate the knownTargetsVar with all the
        -- files in the project so that `knownFiles` can learn about them and
        -- we can generate a complete module graph
    let extendKnownTargets :: [TargetDetails] -> IO ()
extendKnownTargets [TargetDetails]
newTargets = do
          [(Target, [NormalizedFilePath])]
knownTargets <- [TargetDetails]
-> (TargetDetails -> IO [(Target, [NormalizedFilePath])])
-> IO [(Target, [NormalizedFilePath])]
forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM  [TargetDetails]
newTargets ((TargetDetails -> IO [(Target, [NormalizedFilePath])])
 -> IO [(Target, [NormalizedFilePath])])
-> (TargetDetails -> IO [(Target, [NormalizedFilePath])])
-> IO [(Target, [NormalizedFilePath])]
forall a b. (a -> b) -> a -> b
$ \TargetDetails{[NormalizedFilePath]
([FileDiagnostic], Maybe HscEnvEq)
DependencyInfo
Target
targetTarget :: Target
targetEnv :: ([FileDiagnostic], Maybe HscEnvEq)
targetDepends :: DependencyInfo
targetLocations :: [NormalizedFilePath]
targetTarget :: TargetDetails -> Target
targetEnv :: TargetDetails -> ([FileDiagnostic], Maybe HscEnvEq)
targetDepends :: TargetDetails -> DependencyInfo
targetLocations :: TargetDetails -> [NormalizedFilePath]
..} ->
            case Target
targetTarget of
              TargetFile NormalizedFilePath
f -> do
                -- If a target file has multiple possible locations, then we
                -- assume they are all separate file targets.
                -- This happens with '.hs-boot' files if they are in the root directory of the project.
                -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'.
                -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the
                -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'.
                -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either
                --
                --  * TargetFile Foo.hs-boot
                --  * TargetModule Foo
                --
                -- If we don't generate a TargetFile for each potential location, we will only have
                -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'
                -- and also not find 'TargetModule Foo'.
                [NormalizedFilePath]
fs <- (NormalizedFilePath -> IO Bool)
-> [NormalizedFilePath] -> IO [NormalizedFilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
IO.doesFileExist (String -> IO Bool)
-> (NormalizedFilePath -> String) -> NormalizedFilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) [NormalizedFilePath]
targetLocations
                [(Target, [NormalizedFilePath])]
-> IO [(Target, [NormalizedFilePath])]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Target, [NormalizedFilePath])]
 -> IO [(Target, [NormalizedFilePath])])
-> [(Target, [NormalizedFilePath])]
-> IO [(Target, [NormalizedFilePath])]
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> (Target, [NormalizedFilePath]))
-> [NormalizedFilePath] -> [(Target, [NormalizedFilePath])]
forall a b. (a -> b) -> [a] -> [b]
map (\NormalizedFilePath
fp -> (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
fp, [NormalizedFilePath
fp])) ([NormalizedFilePath] -> [NormalizedFilePath]
forall a. Ord a => [a] -> [a]
nubOrd (NormalizedFilePath
fNormalizedFilePath -> [NormalizedFilePath] -> [NormalizedFilePath]
forall a. a -> [a] -> [a]
:[NormalizedFilePath]
fs))
              TargetModule ModuleName
_ -> do
                [NormalizedFilePath]
found <- (NormalizedFilePath -> IO Bool)
-> [NormalizedFilePath] -> IO [NormalizedFilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
IO.doesFileExist (String -> IO Bool)
-> (NormalizedFilePath -> String) -> NormalizedFilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) [NormalizedFilePath]
targetLocations
                [(Target, [NormalizedFilePath])]
-> IO [(Target, [NormalizedFilePath])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Target
targetTarget, [NormalizedFilePath]
found)]
          Maybe (HashMap Target (HashSet NormalizedFilePath))
hasUpdate <- IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
-> IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
 -> IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
-> IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
-> IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
forall a b. (a -> b) -> a -> b
$ STM (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
-> IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
forall a. STM a -> IO a
atomically (STM (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
 -> IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))))
-> STM (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
-> IO (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
forall a b. (a -> b) -> a -> b
$ do
            Hashed (HashMap Target (HashSet NormalizedFilePath))
known <- TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
-> STM (Hashed (HashMap Target (HashSet NormalizedFilePath)))
forall a. TVar a -> STM a
readTVar TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar
            let known' :: Hashed (HashMap Target (HashSet NormalizedFilePath))
known' = ((HashMap Target (HashSet NormalizedFilePath)
  -> HashMap Target (HashSet NormalizedFilePath))
 -> Hashed (HashMap Target (HashSet NormalizedFilePath))
 -> Hashed (HashMap Target (HashSet NormalizedFilePath)))
-> Hashed (HashMap Target (HashSet NormalizedFilePath))
-> (HashMap Target (HashSet NormalizedFilePath)
    -> HashMap Target (HashSet NormalizedFilePath))
-> Hashed (HashMap Target (HashSet NormalizedFilePath))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HashMap Target (HashSet NormalizedFilePath)
 -> HashMap Target (HashSet NormalizedFilePath))
-> Hashed (HashMap Target (HashSet NormalizedFilePath))
-> Hashed (HashMap Target (HashSet NormalizedFilePath))
forall b a. Hashable b => (a -> b) -> Hashed a -> Hashed b
mapHashed Hashed (HashMap Target (HashSet NormalizedFilePath))
known ((HashMap Target (HashSet NormalizedFilePath)
  -> HashMap Target (HashSet NormalizedFilePath))
 -> Hashed (HashMap Target (HashSet NormalizedFilePath)))
-> (HashMap Target (HashSet NormalizedFilePath)
    -> HashMap Target (HashSet NormalizedFilePath))
-> Hashed (HashMap Target (HashSet NormalizedFilePath))
forall a b. (a -> b) -> a -> b
$ \HashMap Target (HashSet NormalizedFilePath)
k ->
                            (HashSet NormalizedFilePath
 -> HashSet NormalizedFilePath -> HashSet NormalizedFilePath)
-> HashMap Target (HashSet NormalizedFilePath)
-> HashMap Target (HashSet NormalizedFilePath)
-> HashMap Target (HashSet NormalizedFilePath)
forall k v.
Eq k =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith HashSet NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. Semigroup a => a -> a -> a
(<>) HashMap Target (HashSet NormalizedFilePath)
k (HashMap Target (HashSet NormalizedFilePath)
 -> HashMap Target (HashSet NormalizedFilePath))
-> HashMap Target (HashSet NormalizedFilePath)
-> HashMap Target (HashSet NormalizedFilePath)
forall a b. (a -> b) -> a -> b
$ [(Target, HashSet NormalizedFilePath)]
-> HashMap Target (HashSet NormalizedFilePath)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Target, HashSet NormalizedFilePath)]
 -> HashMap Target (HashSet NormalizedFilePath))
-> [(Target, HashSet NormalizedFilePath)]
-> HashMap Target (HashSet NormalizedFilePath)
forall a b. (a -> b) -> a -> b
$ ((Target, [NormalizedFilePath])
 -> (Target, HashSet NormalizedFilePath))
-> [(Target, [NormalizedFilePath])]
-> [(Target, HashSet NormalizedFilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (([NormalizedFilePath] -> HashSet NormalizedFilePath)
-> (Target, [NormalizedFilePath])
-> (Target, HashSet NormalizedFilePath)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [NormalizedFilePath] -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList) [(Target, [NormalizedFilePath])]
knownTargets
                hasUpdate :: Maybe (HashMap Target (HashSet NormalizedFilePath))
hasUpdate = if Hashed (HashMap Target (HashSet NormalizedFilePath))
known Hashed (HashMap Target (HashSet NormalizedFilePath))
-> Hashed (HashMap Target (HashSet NormalizedFilePath)) -> Bool
forall a. Eq a => a -> a -> Bool
/= Hashed (HashMap Target (HashSet NormalizedFilePath))
known' then HashMap Target (HashSet NormalizedFilePath)
-> Maybe (HashMap Target (HashSet NormalizedFilePath))
forall a. a -> Maybe a
Just (Hashed (HashMap Target (HashSet NormalizedFilePath))
-> HashMap Target (HashSet NormalizedFilePath)
forall a. Hashed a -> a
unhashed Hashed (HashMap Target (HashSet NormalizedFilePath))
known') else Maybe (HashMap Target (HashSet NormalizedFilePath))
forall a. Maybe a
Nothing
            TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
-> Hashed (HashMap Target (HashSet NormalizedFilePath)) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Hashed (HashMap Target (HashSet NormalizedFilePath)))
knownTargetsVar Hashed (HashMap Target (HashSet NormalizedFilePath))
known'
            IO ()
logDirtyKeys <- ShakeExtras
-> GetKnownTargets -> [NormalizedFilePath] -> STM (IO ())
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys ShakeExtras
extras GetKnownTargets
GetKnownTargets [NormalizedFilePath
emptyFilePath]
            IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
-> STM (IO (Maybe (HashMap Target (HashSet NormalizedFilePath))))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
logDirtyKeys IO ()
-> IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
-> IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (HashMap Target (HashSet NormalizedFilePath))
-> IO (Maybe (HashMap Target (HashSet NormalizedFilePath)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HashMap Target (HashSet NormalizedFilePath))
hasUpdate)
          Maybe (HashMap Target (HashSet NormalizedFilePath))
-> (HashMap Target (HashSet NormalizedFilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (HashMap Target (HashSet NormalizedFilePath))
hasUpdate ((HashMap Target (HashSet NormalizedFilePath) -> IO ()) -> IO ())
-> (HashMap Target (HashSet NormalizedFilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap Target (HashSet NormalizedFilePath)
x ->
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ HashMap Target (HashSet NormalizedFilePath) -> Log
LogKnownFilesUpdated HashMap Target (HashSet NormalizedFilePath)
x

    -- Create a new HscEnv from a hieYaml root and a set of options
    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
                     -> IO ([ComponentInfo], [ComponentInfo])
        packageSetup :: (Maybe String, NormalizedFilePath, ComponentOptions, String)
-> IO ([ComponentInfo], [ComponentInfo])
packageSetup (Maybe String
hieYaml, NormalizedFilePath
cfp, ComponentOptions
opts, String
libDir) = do
          -- Parse DynFlags for the newly discovered component
          HscEnv
hscEnv <- NameCache -> String -> IO HscEnv
emptyHscEnv NameCache
ideNc String
libDir
          NonEmpty (DynFlags, [Target])
newTargetDfs <- HscEnv
-> Ghc (NonEmpty (DynFlags, [Target]))
-> IO (NonEmpty (DynFlags, [Target]))
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
hscEnv (Ghc (NonEmpty (DynFlags, [Target]))
 -> IO (NonEmpty (DynFlags, [Target])))
-> Ghc (NonEmpty (DynFlags, [Target]))
-> IO (NonEmpty (DynFlags, [Target]))
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> Ghc (NonEmpty (DynFlags, [Target]))
forall (m :: * -> *).
GhcMonad m =>
NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> m (NonEmpty (DynFlags, [Target]))
setOptions NormalizedFilePath
cfp ComponentOptions
opts (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv)
          let deps :: [String]
deps = ComponentOptions -> [String]
componentDependencies ComponentOptions
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
hieYaml
          DependencyInfo
dep_info <- [String] -> IO DependencyInfo
getDependencyInfo [String]
deps
          -- Now lookup to see whether we are combining with an existing HscEnv
          -- or making a new one. The lookup returns the HscEnv and a list of
          -- information about other components loaded into the HscEnv
          -- (unitId, DynFlag, Targets)
          Var HieMap
-> (HieMap -> IO (HieMap, ([ComponentInfo], [ComponentInfo])))
-> IO ([ComponentInfo], [ComponentInfo])
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var HieMap
hscEnvs ((HieMap -> IO (HieMap, ([ComponentInfo], [ComponentInfo])))
 -> IO ([ComponentInfo], [ComponentInfo]))
-> (HieMap -> IO (HieMap, ([ComponentInfo], [ComponentInfo])))
-> IO ([ComponentInfo], [ComponentInfo])
forall a b. (a -> b) -> a -> b
$ \HieMap
m -> do
              -- Just deps if there's already an HscEnv
              -- Nothing is it's the first time we are making an HscEnv
              let oldDeps :: Maybe [RawComponentInfo]
oldDeps = Maybe String -> HieMap -> Maybe [RawComponentInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Maybe String
hieYaml HieMap
m
              let -- Add the raw information about this component to the list
                  -- We will modify the unitId and DynFlags used for
                  -- compilation but these are the true source of
                  -- information.
                  new_deps :: NonEmpty RawComponentInfo
new_deps = ((DynFlags, [Target]) -> RawComponentInfo)
-> NonEmpty (DynFlags, [Target]) -> NonEmpty RawComponentInfo
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(DynFlags
df, [Target]
targets) -> UnitId
-> DynFlags
-> [Target]
-> NormalizedFilePath
-> ComponentOptions
-> DependencyInfo
-> RawComponentInfo
RawComponentInfo (DynFlags -> UnitId
homeUnitId_ DynFlags
df) DynFlags
df [Target]
targets NormalizedFilePath
cfp ComponentOptions
opts DependencyInfo
dep_info) NonEmpty (DynFlags, [Target])
newTargetDfs
                  all_deps :: NonEmpty RawComponentInfo
all_deps = NonEmpty RawComponentInfo
new_deps NonEmpty RawComponentInfo
-> [RawComponentInfo] -> NonEmpty RawComponentInfo
forall a. NonEmpty a -> [a] -> NonEmpty a
`NE.appendList` [RawComponentInfo]
-> ([RawComponentInfo] -> [RawComponentInfo])
-> Maybe [RawComponentInfo]
-> [RawComponentInfo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [RawComponentInfo] -> [RawComponentInfo]
forall a. a -> a
id Maybe [RawComponentInfo]
oldDeps
                  -- Get all the unit-ids for things in this component
                  _inplace :: [UnitId]
_inplace = (RawComponentInfo -> UnitId) -> [RawComponentInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map RawComponentInfo -> UnitId
rawComponentUnitId ([RawComponentInfo] -> [UnitId]) -> [RawComponentInfo] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ NonEmpty RawComponentInfo -> [RawComponentInfo]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty RawComponentInfo
all_deps

              NonEmpty ComponentInfo
all_deps' <- NonEmpty RawComponentInfo
-> (RawComponentInfo -> IO ComponentInfo)
-> IO (NonEmpty ComponentInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty RawComponentInfo
all_deps ((RawComponentInfo -> IO ComponentInfo)
 -> IO (NonEmpty ComponentInfo))
-> (RawComponentInfo -> IO ComponentInfo)
-> IO (NonEmpty ComponentInfo)
forall a b. (a -> b) -> a -> b
$ \RawComponentInfo{[Target]
DependencyInfo
UnitId
DynFlags
ComponentOptions
NormalizedFilePath
rawComponentUnitId :: RawComponentInfo -> UnitId
rawComponentUnitId :: UnitId
rawComponentDynFlags :: DynFlags
rawComponentTargets :: [Target]
rawComponentFP :: NormalizedFilePath
rawComponentCOptions :: ComponentOptions
rawComponentDependencyInfo :: DependencyInfo
rawComponentDynFlags :: RawComponentInfo -> DynFlags
rawComponentTargets :: RawComponentInfo -> [Target]
rawComponentFP :: RawComponentInfo -> NormalizedFilePath
rawComponentCOptions :: RawComponentInfo -> ComponentOptions
rawComponentDependencyInfo :: RawComponentInfo -> DependencyInfo
..} -> do
                  -- Remove all inplace dependencies from package flags for
                  -- components in this HscEnv
#if MIN_VERSION_ghc(9,3,0)
                  let (DynFlags
df2, [UnitId]
uids) = (DynFlags
rawComponentDynFlags, [])
#else
                  let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags
#endif
                  let prefix :: String
prefix = UnitId -> String
forall a. Show a => a -> String
show UnitId
rawComponentUnitId
                  -- See Note [Avoiding bad interface files]
                  let hscComponents :: [String]
hscComponents = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Show a => a -> String
show [UnitId]
uids
                      cacheDirOpts :: [String]
cacheDirOpts = [String]
hscComponents [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ComponentOptions -> [String]
componentOptions ComponentOptions
opts
                  CacheDirs
cacheDirs <- IO CacheDirs -> IO CacheDirs
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CacheDirs -> IO CacheDirs) -> IO CacheDirs -> IO CacheDirs
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO CacheDirs
getCacheDirs String
prefix [String]
cacheDirOpts
                  DynFlags
processed_df <- Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> IO DynFlags
forall (m :: * -> *).
MonadUnliftIO m =>
Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags
setCacheDirs Recorder (WithPriority Log)
recorder CacheDirs
cacheDirs DynFlags
df2
                  -- The final component information, mostly the same but the DynFlags don't
                  -- contain any packages which are also loaded
                  -- into the same component.
                  ComponentInfo -> IO ComponentInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentInfo -> IO ComponentInfo)
-> ComponentInfo -> IO ComponentInfo
forall a b. (a -> b) -> a -> b
$ ComponentInfo
                           { componentUnitId :: UnitId
componentUnitId = UnitId
rawComponentUnitId
                           , componentDynFlags :: DynFlags
componentDynFlags = DynFlags
processed_df
                           , componentInternalUnits :: [UnitId]
componentInternalUnits = [UnitId]
uids
                           , componentTargets :: [Target]
componentTargets = [Target]
rawComponentTargets
                           , componentFP :: NormalizedFilePath
componentFP = NormalizedFilePath
rawComponentFP
                           , componentCOptions :: ComponentOptions
componentCOptions = ComponentOptions
rawComponentCOptions
                           , componentDependencyInfo :: DependencyInfo
componentDependencyInfo = DependencyInfo
rawComponentDependencyInfo
                           }
              -- Modify the map so the hieYaml now maps to the newly updated
              -- ComponentInfos
              -- Returns
              -- . The information for the new component which caused this cache miss
              -- . The modified information (without -inplace flags) for
              --   existing packages
              let ([ComponentInfo]
new,[ComponentInfo]
old) = Int -> NonEmpty ComponentInfo -> ([ComponentInfo], [ComponentInfo])
forall a. Int -> NonEmpty a -> ([a], [a])
NE.splitAt (NonEmpty RawComponentInfo -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty RawComponentInfo
new_deps) NonEmpty ComponentInfo
all_deps'
              (HieMap, ([ComponentInfo], [ComponentInfo]))
-> IO (HieMap, ([ComponentInfo], [ComponentInfo]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> [RawComponentInfo] -> HieMap -> HieMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Maybe String
hieYaml (NonEmpty RawComponentInfo -> [RawComponentInfo]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty RawComponentInfo
all_deps) HieMap
m, ([ComponentInfo]
new,[ComponentInfo]
old))


    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
                -> IO (IdeResult HscEnvEq,[FilePath])
        session :: (Maybe String, NormalizedFilePath, ComponentOptions, String)
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
session args :: (Maybe String, NormalizedFilePath, ComponentOptions, String)
args@(Maybe String
hieYaml, NormalizedFilePath
_cfp, ComponentOptions
_opts, String
_libDir) = do
          ([ComponentInfo]
new_deps, [ComponentInfo]
old_deps) <- (Maybe String, NormalizedFilePath, ComponentOptions, String)
-> IO ([ComponentInfo], [ComponentInfo])
packageSetup (Maybe String, NormalizedFilePath, ComponentOptions, String)
args

          -- For each component, now make a new HscEnvEq which contains the
          -- HscEnv for the hie.yaml file but the DynFlags for that component
          -- For GHC's supporting multi component sessions, we create a shared
          -- HscEnv but set the active component accordingly
          HscEnv
hscEnv <- NameCache -> String -> IO HscEnv
emptyHscEnv NameCache
ideNc String
_libDir
          let new_cache :: [ComponentInfo]
-> [ComponentInfo]
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
new_cache = Recorder (WithPriority Log)
-> [String]
-> Maybe String
-> NormalizedFilePath
-> HscEnv
-> [ComponentInfo]
-> [ComponentInfo]
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
newComponentCache Recorder (WithPriority Log)
recorder [String]
optExtensions Maybe String
hieYaml NormalizedFilePath
_cfp HscEnv
hscEnv
          [([TargetDetails],
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
all_target_details <- [ComponentInfo]
-> [ComponentInfo]
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
new_cache [ComponentInfo]
old_deps [ComponentInfo]
new_deps

          let all_targets :: [TargetDetails]
all_targets = (([TargetDetails],
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
 -> [TargetDetails])
-> [([TargetDetails],
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [TargetDetails]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([TargetDetails],
 (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> [TargetDetails]
forall a b. (a, b) -> a
fst [([TargetDetails],
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
all_target_details

          let this_flags_map :: HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags_map = [(NormalizedFilePath,
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ((TargetDetails
 -> [(NormalizedFilePath,
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))])
-> [TargetDetails]
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TargetDetails
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
toFlagsMap [TargetDetails]
all_targets)

          IO FlagsMap -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FlagsMap -> IO ()) -> IO FlagsMap -> IO ()
forall a b. (a -> b) -> a -> b
$ Var FlagsMap -> (FlagsMap -> FlagsMap) -> IO FlagsMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var FlagsMap
fileToFlags ((FlagsMap -> FlagsMap) -> IO FlagsMap)
-> (FlagsMap -> FlagsMap) -> IO FlagsMap
forall a b. (a -> b) -> a -> b
$
              Maybe String
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> FlagsMap
-> FlagsMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Maybe String
hieYaml HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags_map
          IO FilesMap -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilesMap -> IO ()) -> IO FilesMap -> IO ()
forall a b. (a -> b) -> a -> b
$ Var FilesMap -> (FilesMap -> FilesMap) -> IO FilesMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var FilesMap
filesMap ((FilesMap -> FilesMap) -> IO FilesMap)
-> (FilesMap -> FilesMap) -> IO FilesMap
forall a b. (a -> b) -> a -> b
$
              (FilesMap -> FilesMap -> FilesMap)
-> FilesMap -> FilesMap -> FilesMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilesMap -> FilesMap -> FilesMap
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
HM.union ([(NormalizedFilePath, Maybe String)] -> FilesMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([NormalizedFilePath]
-> [Maybe String] -> [(NormalizedFilePath, Maybe String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((NormalizedFilePath,
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
 -> NormalizedFilePath)
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath,
 (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> NormalizedFilePath
forall a b. (a, b) -> a
fst ([(NormalizedFilePath,
   (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
 -> [NormalizedFilePath])
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [NormalizedFilePath]
forall a b. (a -> b) -> a -> b
$ (TargetDetails
 -> [(NormalizedFilePath,
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))])
-> [TargetDetails]
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TargetDetails
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
toFlagsMap [TargetDetails]
all_targets) (Maybe String -> [Maybe String]
forall a. a -> [a]
repeat Maybe String
hieYaml)))

          IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [TargetDetails] -> IO ()
extendKnownTargets [TargetDetails]
all_targets

          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
          IO ()
invalidateShakeCache

          -- The VFS doesn't change on cradle edits, re-use the old one.
          VFSModified -> String -> [DelayedAction ()] -> IO ()
restartShakeSession VFSModified
VFSUnmodified String
"new component" []

          -- Typecheck all files in the project on startup
          Bool
checkProject <- IO Bool
getCheckProject
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ComponentInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ComponentInfo]
new_deps Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
checkProject) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                [NormalizedFilePath]
cfps' <- IO [NormalizedFilePath] -> IO [NormalizedFilePath]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [NormalizedFilePath] -> IO [NormalizedFilePath])
-> IO [NormalizedFilePath] -> IO [NormalizedFilePath]
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> IO Bool)
-> [NormalizedFilePath] -> IO [NormalizedFilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
IO.doesFileExist (String -> IO Bool)
-> (NormalizedFilePath -> String) -> NormalizedFilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) ((TargetDetails -> [NormalizedFilePath])
-> [TargetDetails] -> [NormalizedFilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TargetDetails -> [NormalizedFilePath]
targetLocations [TargetDetails]
all_targets)
                IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction () -> IO (IO ())
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras
extras (DelayedAction () -> IO (IO ())) -> DelayedAction () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ String -> Priority -> Action () -> DelayedAction ()
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction String
"InitialLoad" Priority
Debug (Action () -> DelayedAction ()) -> Action () -> DelayedAction ()
forall a b. (a -> b) -> a -> b
$ Action () -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
                    [Maybe FileVersion]
mmt <- GetModificationTime
-> [NormalizedFilePath] -> Action [Maybe FileVersion]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModificationTime
GetModificationTime [NormalizedFilePath]
cfps'
                    let cs_exist :: [NormalizedFilePath]
cs_exist = [Maybe NormalizedFilePath] -> [NormalizedFilePath]
forall a. [Maybe a] -> [a]
catMaybes ((NormalizedFilePath
 -> Maybe FileVersion -> Maybe NormalizedFilePath)
-> [NormalizedFilePath]
-> [Maybe FileVersion]
-> [Maybe NormalizedFilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NormalizedFilePath -> Maybe FileVersion -> Maybe NormalizedFilePath
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) [NormalizedFilePath]
cfps' [Maybe FileVersion]
mmt)
                    [Maybe HiFileResult]
modIfaces <- GetModIface -> [NormalizedFilePath] -> Action [Maybe HiFileResult]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModIface
GetModIface [NormalizedFilePath]
cs_exist
                    -- update exports map
                    ShakeExtras
shakeExtras <- Action ShakeExtras
getShakeExtras
                    let !exportsMap' :: ExportsMap
exportsMap' = [ModIface] -> ExportsMap
createExportsMap ([ModIface] -> ExportsMap) -> [ModIface] -> ExportsMap
forall a b. (a -> b) -> a -> b
$ (Maybe HiFileResult -> Maybe ModIface)
-> [Maybe HiFileResult] -> [ModIface]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((HiFileResult -> ModIface) -> Maybe HiFileResult -> Maybe ModIface
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HiFileResult -> ModIface
hirModIface) [Maybe HiFileResult]
modIfaces
                    IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ExportsMap -> (ExportsMap -> ExportsMap) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ShakeExtras -> TVar ExportsMap
exportsMap ShakeExtras
shakeExtras) (ExportsMap
exportsMap' ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<>)

          (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([FileDiagnostic], Maybe HscEnvEq), [String])
 -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a b. (a -> b) -> a -> b
$ (DependencyInfo -> [String])
-> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> (([FileDiagnostic], Maybe HscEnvEq), [String])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DependencyInfo -> [String]
forall k a. Map k a -> [k]
Map.keys ((([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
 -> (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a b. (a -> b) -> a -> b
$ HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags_map HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> NormalizedFilePath
-> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! NormalizedFilePath
_cfp

    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
        consultCradle :: Maybe String
-> String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
consultCradle Maybe String
hieYaml String
cfp = do
           String
lfpLog <- (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
makeRelative String
cfp ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
           Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogCradlePath String
lfpLog

           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
hieYaml) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogCradleNotFound String
lfpLog

           Cradle Void
cradle <- Recorder (WithPriority Log)
-> Maybe String -> String -> IO (Cradle Void)
loadCradle Recorder (WithPriority Log)
recorder Maybe String
hieYaml String
dir
           -- TODO: Why are we repeating the same command we have on line 646?
           String
lfp <- (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
makeRelative String
cfp ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory

           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
optTesting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (LanguageContextEnv Config) -> LspT Config IO () -> IO ()
forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv Config)
lspEnv (LspT Config IO () -> IO ()) -> LspT Config IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            SServerMethod ('Method_CustomMethod "ghcide/cradle/loaded")
-> MessageParams ('Method_CustomMethod "ghcide/cradle/loaded")
-> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification (Proxy "ghcide/cradle/loaded"
-> SServerMethod ('Method_CustomMethod "ghcide/cradle/loaded")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"ghcide/cradle/loaded")) (String -> Value
forall a. ToJSON a => a -> Value
toJSON String
cfp)

           -- Display a user friendly progress message here: They probably don't know what a cradle is
           let progMsg :: Text
progMsg = Text
"Setting up " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ShowS
takeBaseName (Cradle Void -> String
forall a. Cradle a -> String
cradleRootDir Cradle Void
cradle))
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
lfp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
           Either [CradleError] (ComponentOptions, String)
eopts <- Maybe (LanguageContextEnv Config)
-> (LspT
      Config IO (Either [CradleError] (ComponentOptions, String))
    -> LspT
         Config IO (Either [CradleError] (ComponentOptions, String)))
-> IO (Either [CradleError] (ComponentOptions, String))
-> IO (Either [CradleError] (ComponentOptions, String))
forall (m :: * -> *) c a.
Monad m =>
Maybe (LanguageContextEnv c)
-> (LspT c m a -> LspT c m a) -> m a -> m a
mRunLspTCallback Maybe (LanguageContextEnv Config)
lspEnv (Text
-> ProgressCancellable
-> LspT Config IO (Either [CradleError] (ComponentOptions, String))
-> LspT Config IO (Either [CradleError] (ComponentOptions, String))
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
progMsg ProgressCancellable
NotCancellable) (IO (Either [CradleError] (ComponentOptions, String))
 -> IO (Either [CradleError] (ComponentOptions, String)))
-> IO (Either [CradleError] (ComponentOptions, String))
-> IO (Either [CradleError] (ComponentOptions, String))
forall a b. (a -> b) -> a -> b
$
              String
-> ((String -> String -> IO ())
    -> IO (Either [CradleError] (ComponentOptions, String)))
-> IO (Either [CradleError] (ComponentOptions, String))
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> ((String -> String -> m ()) -> m a) -> m a
withTrace String
"Load cradle" (((String -> String -> IO ())
  -> IO (Either [CradleError] (ComponentOptions, String)))
 -> IO (Either [CradleError] (ComponentOptions, String)))
-> ((String -> String -> IO ())
    -> IO (Either [CradleError] (ComponentOptions, String)))
-> IO (Either [CradleError] (ComponentOptions, String))
forall a b. (a -> b) -> a -> b
$ \String -> String -> IO ()
addTag -> do
                  String -> String -> IO ()
addTag String
"file" String
lfp
                  [String]
old_files <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
cradle_files
                  Either [CradleError] (ComponentOptions, String)
res <- Recorder (WithPriority Log)
-> Cradle Void
-> String
-> [String]
-> IO (Either [CradleError] (ComponentOptions, String))
cradleToOptsAndLibDir Recorder (WithPriority Log)
recorder Cradle Void
cradle String
cfp [String]
old_files
                  String -> String -> IO ()
addTag String
"result" (Either [CradleError] (ComponentOptions, String) -> String
forall a. Show a => a -> String
show Either [CradleError] (ComponentOptions, String)
res)
                  Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either [CradleError] (ComponentOptions, String)
res

           Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Either [CradleError] (ComponentOptions, String) -> Log
LogSessionLoadingResult Either [CradleError] (ComponentOptions, String)
eopts
           case Either [CradleError] (ComponentOptions, String)
eopts of
             -- The cradle gave us some options so get to work turning them
             -- into and HscEnv.
             Right (ComponentOptions
opts, String
libDir) -> do
               InstallationCheck
installationCheck <- GhcVersionChecker
ghcVersionChecker String
libDir
               case InstallationCheck
installationCheck of
                 InstallationNotFound{String
libdir :: String
$sel:libdir:InstallationChecked :: InstallationCheck -> String
..} ->
                     String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. HasCallStack => String -> a
error (String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a b. (a -> b) -> a -> b
$ String
"GHC installation not found in libdir: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
libdir
                 InstallationMismatch{String
Version
$sel:libdir:InstallationChecked :: InstallationCheck -> String
libdir :: String
compileTime :: Version
runTime :: Version
$sel:compileTime:InstallationChecked :: InstallationCheck -> Version
$sel:runTime:InstallationChecked :: InstallationCheck -> Version
..} ->
                     (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String -> PackageSetupException -> FileDiagnostic
renderPackageSetupException String
cfp GhcVersionMismatch{Version
compileTime :: Version
runTime :: Version
compileTime :: Version
runTime :: Version
..}], Maybe HscEnvEq
forall a. Maybe a
Nothing),[])
                 InstallationChecked Version
_compileTime Ghc PackageCheckResult
_ghcLibCheck -> do
                   IORef [String] -> ([String] -> ([String], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [String]
cradle_files (\[String]
xs -> (String
cfpString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs,()))
                   (Maybe String, NormalizedFilePath, ComponentOptions, String)
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
session (Maybe String
hieYaml, String -> NormalizedFilePath
toNormalizedFilePath' String
cfp, ComponentOptions
opts, String
libDir)
             -- Failure case, either a cradle error or the none cradle
             Left [CradleError]
err -> do
               DependencyInfo
dep_info <- [String] -> IO DependencyInfo
getDependencyInfo (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
hieYaml)
               let ncfp :: NormalizedFilePath
ncfp = String -> NormalizedFilePath
toNormalizedFilePath' String
cfp
               let res :: ([FileDiagnostic], Maybe HscEnvEq)
res = ((CradleError -> FileDiagnostic)
-> [CradleError] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (\CradleError
err' -> CradleError -> Cradle Void -> NormalizedFilePath -> FileDiagnostic
forall a.
CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
renderCradleError CradleError
err' Cradle Void
cradle NormalizedFilePath
ncfp) [CradleError]
err, Maybe HscEnvEq
forall a. Maybe a
Nothing)
               IO FlagsMap -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FlagsMap -> IO ()) -> IO FlagsMap -> IO ()
forall a b. (a -> b) -> a -> b
$ Var FlagsMap -> (FlagsMap -> FlagsMap) -> IO FlagsMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var FlagsMap
fileToFlags ((FlagsMap -> FlagsMap) -> IO FlagsMap)
-> (FlagsMap -> FlagsMap) -> IO FlagsMap
forall a b. (a -> b) -> a -> b
$
                    (HashMap
   NormalizedFilePath
   (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
 -> HashMap
      NormalizedFilePath
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
 -> HashMap
      NormalizedFilePath
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> Maybe String
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> FlagsMap
-> FlagsMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
HM.union Maybe String
hieYaml (NormalizedFilePath
-> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton NormalizedFilePath
ncfp (([FileDiagnostic], Maybe HscEnvEq)
res, DependencyInfo
dep_info))
               IO FilesMap -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilesMap -> IO ()) -> IO FilesMap -> IO ()
forall a b. (a -> b) -> a -> b
$ Var FilesMap -> (FilesMap -> FilesMap) -> IO FilesMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var FilesMap
filesMap ((FilesMap -> FilesMap) -> IO FilesMap)
-> (FilesMap -> FilesMap) -> IO FilesMap
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Maybe String -> FilesMap -> FilesMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert NormalizedFilePath
ncfp Maybe String
hieYaml
               (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([FileDiagnostic], Maybe HscEnvEq)
res, [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
hieYaml [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (CradleError -> [String]) -> [CradleError] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CradleError -> [String]
cradleErrorDependencies [CradleError]
err)

    -- This caches the mapping from hie.yaml + Mod.hs -> [String]
    -- Returns the Ghc session and the cradle dependencies
    let sessionOpts :: (Maybe FilePath, FilePath)
                    -> IO (IdeResult HscEnvEq, [FilePath])
        sessionOpts :: (Maybe String, String)
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
sessionOpts (Maybe String
hieYaml, String
file) = do
          HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
v <- HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> Maybe String
-> FlagsMap
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v. HashMap k v
HM.empty Maybe String
hieYaml (FlagsMap
 -> HashMap
      NormalizedFilePath
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> IO FlagsMap
-> IO
     (HashMap
        NormalizedFilePath
        (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var FlagsMap -> IO FlagsMap
forall a. Var a -> IO a
readVar Var FlagsMap
fileToFlags
          String
cfp <- String -> IO String
makeAbsolute String
file
          case NormalizedFilePath
-> HashMap
     NormalizedFilePath
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> Maybe (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (String -> NormalizedFilePath
toNormalizedFilePath' String
cfp) HashMap
  NormalizedFilePath
  (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
v of
            Just (([FileDiagnostic], Maybe HscEnvEq)
opts, DependencyInfo
old_di) -> do
              Bool
deps_ok <- DependencyInfo -> IO Bool
checkDependencyInfo DependencyInfo
old_di
              if Bool -> Bool
not Bool
deps_ok
                then do
                  -- If the dependencies are out of date then clear both caches and start
                  -- again.
                  Var FlagsMap -> (FlagsMap -> IO FlagsMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FlagsMap
fileToFlags (IO FlagsMap -> FlagsMap -> IO FlagsMap
forall a b. a -> b -> a
const (FlagsMap -> IO FlagsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FlagsMap
forall k a. Map k a
Map.empty))
                  -- Keep the same name cache
                  Var HieMap -> (HieMap -> IO HieMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var HieMap
hscEnvs (HieMap -> IO HieMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HieMap -> IO HieMap) -> (HieMap -> HieMap) -> HieMap -> IO HieMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RawComponentInfo] -> [RawComponentInfo])
-> Maybe String -> HieMap -> HieMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\[RawComponentInfo]
_ -> []) Maybe String
hieYaml )
                  Maybe String
-> String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
consultCradle Maybe String
hieYaml String
cfp
                else (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([FileDiagnostic], Maybe HscEnvEq)
opts, DependencyInfo -> [String]
forall k a. Map k a -> [k]
Map.keys DependencyInfo
old_di)
            Maybe (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
Nothing -> Maybe String
-> String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
consultCradle Maybe String
hieYaml String
cfp

    -- The main function which gets options for a file. We only want one of these running
    -- at a time. Therefore the IORef contains the currently running cradle, if we try
    -- to get some more options then we wait for the currently running action to finish
    -- before attempting to do so.
    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
        getOptions :: String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
getOptions String
file = do
            NormalizedFilePath
ncfp <- String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath)
-> IO String -> IO NormalizedFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute String
file
            Maybe (Maybe String)
cachedHieYamlLocation <- NormalizedFilePath -> FilesMap -> Maybe (Maybe String)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NormalizedFilePath
ncfp (FilesMap -> Maybe (Maybe String))
-> IO FilesMap -> IO (Maybe (Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var FilesMap -> IO FilesMap
forall a. Var a -> IO a
readVar Var FilesMap
filesMap
            Maybe String
hieYaml <- String -> IO (Maybe String)
cradleLoc String
file
            (Maybe String, String)
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
sessionOpts (Maybe (Maybe String) -> Maybe String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe String)
cachedHieYamlLocation Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
hieYaml, String
file) IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> (PackageSetupException
    -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Safe.catch` \PackageSetupException
e ->
                (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String -> PackageSetupException -> FileDiagnostic
renderPackageSetupException String
file PackageSetupException
e], Maybe HscEnvEq
forall a. Maybe a
Nothing), [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
hieYaml)

    (String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> Action IdeGhcSession
returnWithVersion ((String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
 -> Action IdeGhcSession)
-> (String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> Action IdeGhcSession
forall a b. (a -> b) -> a -> b
$ \String
file -> do
      (([FileDiagnostic], Maybe HscEnvEq), [String])
opts <- IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (([FileDiagnostic], Maybe HscEnvEq), [String])
 -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a b. (a -> b) -> a -> b
$ IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
 -> IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a b. (a -> b) -> a -> b
$ IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
 -> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a b. (a -> b) -> a -> b
$ Var (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> (Async (([FileDiagnostic], Maybe HscEnvEq), [String])
    -> IO
         (Async (([FileDiagnostic], Maybe HscEnvEq), [String]),
          IO (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
runningCradle ((Async (([FileDiagnostic], Maybe HscEnvEq), [String])
  -> IO
       (Async (([FileDiagnostic], Maybe HscEnvEq), [String]),
        IO (([FileDiagnostic], Maybe HscEnvEq), [String])))
 -> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> (Async (([FileDiagnostic], Maybe HscEnvEq), [String])
    -> IO
         (Async (([FileDiagnostic], Maybe HscEnvEq), [String]),
          IO (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> IO (IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a b. (a -> b) -> a -> b
$ \Async (([FileDiagnostic], Maybe HscEnvEq), [String])
as -> do
        -- If the cradle is not finished, then wait for it to finish.
        IO (([FileDiagnostic], Maybe HscEnvEq), [String]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (([FileDiagnostic], Maybe HscEnvEq), [String]) -> IO ())
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String]) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. Async a -> IO a
wait Async (([FileDiagnostic], Maybe HscEnvEq), [String])
as
        Async (([FileDiagnostic], Maybe HscEnvEq), [String])
asyncRes <- IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a. IO a -> IO (Async a)
async (IO (([FileDiagnostic], Maybe HscEnvEq), [String])
 -> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String])))
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (Async (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a b. (a -> b) -> a -> b
$ String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
getOptions String
file
        (Async (([FileDiagnostic], Maybe HscEnvEq), [String]),
 IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
-> IO
     (Async (([FileDiagnostic], Maybe HscEnvEq), [String]),
      IO (([FileDiagnostic], Maybe HscEnvEq), [String]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Async (([FileDiagnostic], Maybe HscEnvEq), [String])
asyncRes, Async (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. Async a -> IO a
wait Async (([FileDiagnostic], Maybe HscEnvEq), [String])
asyncRes)
      (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([FileDiagnostic], Maybe HscEnvEq), [String])
opts

-- | Run the specific cradle on a specific FilePath via hie-bios.
-- This then builds dependencies or whatever based on the cradle, gets the
-- GHC options/dynflags needed for the session and the GHC library directory
cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> [FilePath]
                      -> IO (Either [CradleError] (ComponentOptions, FilePath))
cradleToOptsAndLibDir :: Recorder (WithPriority Log)
-> Cradle Void
-> String
-> [String]
-> IO (Either [CradleError] (ComponentOptions, String))
cradleToOptsAndLibDir Recorder (WithPriority Log)
recorder Cradle Void
cradle String
file [String]
old_files = do
    -- let noneCradleFoundMessage :: FilePath -> T.Text
    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"
    -- Start off by getting the session options
    Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Cradle Void -> Log
LogCradle Cradle Void
cradle
    CradleLoadResult ComponentOptions
cradleRes <- String
-> [String]
-> Cradle Void
-> IO (CradleLoadResult ComponentOptions)
forall a.
String
-> [String] -> Cradle a -> IO (CradleLoadResult ComponentOptions)
HieBios.getCompilerOptions String
file [String]
old_files Cradle Void
cradle
    case CradleLoadResult ComponentOptions
cradleRes of
        CradleSuccess ComponentOptions
r -> do
            -- Now get the GHC lib dir
            CradleLoadResult String
libDirRes <- Cradle Void -> IO (CradleLoadResult String)
forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcLibDir Cradle Void
cradle
            case CradleLoadResult String
libDirRes of
                -- This is the successful path
                CradleSuccess String
libDir -> Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ComponentOptions, String)
-> Either [CradleError] (ComponentOptions, String)
forall a b. b -> Either a b
Right (ComponentOptions
r, String
libDir))
                CradleFail CradleError
err       -> Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, String)
forall a b. a -> Either a b
Left [CradleError
err])
                CradleLoadResult String
CradleNone           -> do
                    Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogNoneCradleFound String
file
                    Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, String)
forall a b. a -> Either a b
Left [])

        CradleFail CradleError
err -> Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, String)
forall a b. a -> Either a b
Left [CradleError
err])
        CradleLoadResult ComponentOptions
CradleNone -> do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogNoneCradleFound String
file
            Either [CradleError] (ComponentOptions, String)
-> IO (Either [CradleError] (ComponentOptions, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, String)
forall a b. a -> Either a b
Left [])

#if MIN_VERSION_ghc(9,3,0)
emptyHscEnv :: NameCache -> FilePath -> IO HscEnv
#else
emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
#endif
emptyHscEnv :: NameCache -> String -> IO HscEnv
emptyHscEnv NameCache
nc String
libDir = do
    -- We call setSessionDynFlags so that the loader is initialised
    -- We need to do this before we call initUnits.
    HscEnv
env <- Maybe String -> Ghc HscEnv -> IO HscEnv
forall a. Maybe String -> Ghc a -> IO a
runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libDir) (Ghc HscEnv -> IO HscEnv) -> Ghc HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
      Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags Ghc DynFlags -> (DynFlags -> Ghc ()) -> Ghc ()
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags Ghc () -> Ghc HscEnv -> Ghc HscEnv
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    -- On GHC 9.2 calling setSessionDynFlags caches the unit databases
    -- for an empty environment. This prevents us from reading the
    -- package database subsequently. So clear the unit db cache in
    -- hsc_unit_dbs
    HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ NameCache -> HscEnv -> HscEnv
setNameCache NameCache
nc (DynFlags -> HscEnv -> HscEnv
hscSetFlags ((HscEnv -> DynFlags
hsc_dflags HscEnv
env){useUnicode = True }) HscEnv
env)
#if !MIN_VERSION_ghc(9,3,0)
              {hsc_unit_dbs = Nothing}
#endif

data TargetDetails = TargetDetails
  {
      TargetDetails -> Target
targetTarget    :: !Target,
      TargetDetails -> ([FileDiagnostic], Maybe HscEnvEq)
targetEnv       :: !(IdeResult HscEnvEq),
      TargetDetails -> DependencyInfo
targetDepends   :: !DependencyInfo,
      TargetDetails -> [NormalizedFilePath]
targetLocations :: ![NormalizedFilePath]
  }

fromTargetId :: [FilePath]          -- ^ import paths
             -> [String]            -- ^ extensions to consider
             -> TargetId
             -> IdeResult HscEnvEq
             -> DependencyInfo
             -> IO [TargetDetails]
-- For a target module we consider all the import paths
fromTargetId :: [String]
-> [String]
-> TargetId
-> ([FileDiagnostic], Maybe HscEnvEq)
-> DependencyInfo
-> IO [TargetDetails]
fromTargetId [String]
is [String]
exts (GHC.TargetModule ModuleName
modName) ([FileDiagnostic], Maybe HscEnvEq)
env DependencyInfo
dep = do
    let fps :: [String]
fps = [String
i String -> ShowS
</> ModuleName -> String
moduleNameSlashes ModuleName
modName String -> ShowS
-<.> String
ext String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
boot
              | String
ext <- [String]
exts
              , String
i <- [String]
is
              , String
boot <- [String
"", String
"-boot"]
              ]
    [NormalizedFilePath]
locs <- (String -> IO NormalizedFilePath)
-> [String] -> IO [NormalizedFilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((String -> NormalizedFilePath)
-> IO String -> IO NormalizedFilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> NormalizedFilePath
toNormalizedFilePath' (IO String -> IO NormalizedFilePath)
-> (String -> IO String) -> String -> IO NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
makeAbsolute) [String]
fps
    [TargetDetails] -> IO [TargetDetails]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Target
-> ([FileDiagnostic], Maybe HscEnvEq)
-> DependencyInfo
-> [NormalizedFilePath]
-> TargetDetails
TargetDetails (ModuleName -> Target
TargetModule ModuleName
modName) ([FileDiagnostic], Maybe HscEnvEq)
env DependencyInfo
dep [NormalizedFilePath]
locs]
-- For a 'TargetFile' we consider all the possible module names
fromTargetId [String]
_ [String]
_ (GHC.TargetFile String
f Maybe Phase
_) ([FileDiagnostic], Maybe HscEnvEq)
env DependencyInfo
deps = do
    NormalizedFilePath
nf <- String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath)
-> IO String -> IO NormalizedFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute String
f
    let other :: NormalizedFilePath
other
          | String
"-boot" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
f = String -> NormalizedFilePath
toNormalizedFilePath' (Int -> ShowS
forall a. Int -> [a] -> [a]
L.dropEnd Int
5 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nf)
          | Bool
otherwise = String -> NormalizedFilePath
toNormalizedFilePath' (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-boot")
    [TargetDetails] -> IO [TargetDetails]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Target
-> ([FileDiagnostic], Maybe HscEnvEq)
-> DependencyInfo
-> [NormalizedFilePath]
-> TargetDetails
TargetDetails (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
nf) ([FileDiagnostic], Maybe HscEnvEq)
env DependencyInfo
deps [NormalizedFilePath
nf, NormalizedFilePath
other]]

toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
toFlagsMap :: TargetDetails
-> [(NormalizedFilePath,
     (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
toFlagsMap TargetDetails{[NormalizedFilePath]
([FileDiagnostic], Maybe HscEnvEq)
DependencyInfo
Target
targetTarget :: TargetDetails -> Target
targetEnv :: TargetDetails -> ([FileDiagnostic], Maybe HscEnvEq)
targetDepends :: TargetDetails -> DependencyInfo
targetLocations :: TargetDetails -> [NormalizedFilePath]
targetTarget :: Target
targetEnv :: ([FileDiagnostic], Maybe HscEnvEq)
targetDepends :: DependencyInfo
targetLocations :: [NormalizedFilePath]
..} =
    [ (NormalizedFilePath
l, (([FileDiagnostic], Maybe HscEnvEq)
targetEnv, DependencyInfo
targetDepends)) | NormalizedFilePath
l <-  [NormalizedFilePath]
targetLocations]


#if MIN_VERSION_ghc(9,3,0)
setNameCache :: NameCache -> HscEnv -> HscEnv
#else
setNameCache :: IORef NameCache -> HscEnv -> HscEnv
#endif
setNameCache :: NameCache -> HscEnv -> HscEnv
setNameCache NameCache
nc HscEnv
hsc = HscEnv
hsc { hsc_NC = nc }

-- | Create a mapping from FilePaths to HscEnvEqs
-- This combines all the components we know about into
-- an appropriate session, which is a multi component
-- session on GHC 9.4+
newComponentCache
         :: Recorder (WithPriority Log)
         -> [String]           -- ^ File extensions to consider
         -> Maybe FilePath     -- ^ Path to cradle
         -> NormalizedFilePath -- ^ Path to file that caused the creation of this component
         -> HscEnv             -- ^ An empty HscEnv
         -> [ComponentInfo]    -- ^ New components to be loaded
         -> [ComponentInfo]    -- ^ old, already existing components
         -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))]
newComponentCache :: Recorder (WithPriority Log)
-> [String]
-> Maybe String
-> NormalizedFilePath
-> HscEnv
-> [ComponentInfo]
-> [ComponentInfo]
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
newComponentCache Recorder (WithPriority Log)
recorder [String]
exts Maybe String
cradlePath NormalizedFilePath
_cfp HscEnv
hsc_env [ComponentInfo]
old_cis [ComponentInfo]
new_cis = do
    let cis :: Map UnitId ComponentInfo
cis = (ComponentInfo -> ComponentInfo -> ComponentInfo)
-> Map UnitId ComponentInfo
-> Map UnitId ComponentInfo
-> Map UnitId ComponentInfo
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ComponentInfo -> ComponentInfo -> ComponentInfo
unionCIs ([ComponentInfo] -> Map UnitId ComponentInfo
mkMap [ComponentInfo]
new_cis) ([ComponentInfo] -> Map UnitId ComponentInfo
mkMap [ComponentInfo]
old_cis)
        -- When we have multiple components with the same uid,
        -- prefer the new one over the old.
        -- However, we might have added some targets to the old unit
        -- (see special target), so preserve those
        unionCIs :: ComponentInfo -> ComponentInfo -> ComponentInfo
unionCIs ComponentInfo
new_ci ComponentInfo
old_ci = ComponentInfo
new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci }
        mkMap :: [ComponentInfo] -> Map UnitId ComponentInfo
mkMap = (ComponentInfo -> ComponentInfo -> ComponentInfo)
-> [(UnitId, ComponentInfo)] -> Map UnitId ComponentInfo
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ComponentInfo -> ComponentInfo -> ComponentInfo
unionCIs ([(UnitId, ComponentInfo)] -> Map UnitId ComponentInfo)
-> ([ComponentInfo] -> [(UnitId, ComponentInfo)])
-> [ComponentInfo]
-> Map UnitId ComponentInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentInfo -> (UnitId, ComponentInfo))
-> [ComponentInfo] -> [(UnitId, ComponentInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\ComponentInfo
ci -> (ComponentInfo -> UnitId
componentUnitId ComponentInfo
ci, ComponentInfo
ci))
    let dfs :: [DynFlags]
dfs = (ComponentInfo -> DynFlags) -> [ComponentInfo] -> [DynFlags]
forall a b. (a -> b) -> [a] -> [b]
map ComponentInfo -> DynFlags
componentDynFlags ([ComponentInfo] -> [DynFlags]) -> [ComponentInfo] -> [DynFlags]
forall a b. (a -> b) -> a -> b
$ Map UnitId ComponentInfo -> [ComponentInfo]
forall k a. Map k a -> [a]
Map.elems Map UnitId ComponentInfo
cis
        uids :: [UnitId]
uids = Map UnitId ComponentInfo -> [UnitId]
forall k a. Map k a -> [k]
Map.keys Map UnitId ComponentInfo
cis
    Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ [UnitId] -> Log
LogMakingNewHscEnv [UnitId]
uids
    HscEnv
hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4
              [DynFlags] -> HscEnv -> IO HscEnv
Compat.initUnits [DynFlags]
dfs HscEnv
hsc_env

#if MIN_VERSION_ghc(9,3,0)
    let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hscEnv') (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hscEnv') [(UnitId, UnitId)]
pkg_deps
        pkg_deps :: [(UnitId, UnitId)]
pkg_deps = do
          UnitId
home_unit_id <- [UnitId]
uids
          HomeUnitEnv
home_unit_env <- Maybe HomeUnitEnv -> [HomeUnitEnv]
forall a. Maybe a -> [a]
maybeToList (Maybe HomeUnitEnv -> [HomeUnitEnv])
-> Maybe HomeUnitEnv -> [HomeUnitEnv]
forall a b. (a -> b) -> a -> b
$ UnitId -> UnitEnvGraph HomeUnitEnv -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
home_unit_id (UnitEnvGraph HomeUnitEnv -> Maybe HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> Maybe HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hscEnv'
          (UnitId -> (UnitId, UnitId)) -> [UnitId] -> [(UnitId, UnitId)]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId
home_unit_id,) (((Unit, Maybe PackageArg) -> UnitId)
-> [(Unit, Maybe PackageArg)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> UnitId
Compat.toUnitId (Unit -> UnitId)
-> ((Unit, Maybe PackageArg) -> Unit)
-> (Unit, Maybe PackageArg)
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit, Maybe PackageArg) -> Unit
forall a b. (a, b) -> a
fst) ([(Unit, Maybe PackageArg)] -> [UnitId])
-> [(Unit, Maybe PackageArg)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitState -> [(Unit, Maybe PackageArg)]
explicitUnits (UnitState -> [(Unit, Maybe PackageArg)])
-> UnitState -> [(Unit, Maybe PackageArg)]
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
home_unit_env)
        multi_errs :: [FileDiagnostic]
multi_errs = (DriverMessages -> FileDiagnostic)
-> [DriverMessages] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> FileDiagnostic
forall a.
Maybe Text
-> Maybe DiagnosticSeverity
-> a
-> Text
-> (a, ShowDiagnostic, Diagnostic)
ideErrorWithSource (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cradle") (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Warning) NormalizedFilePath
_cfp (Text -> FileDiagnostic)
-> (DriverMessages -> Text) -> DriverMessages -> FileDiagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (DriverMessages -> String) -> DriverMessages -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DriverMessages -> String
forall a. Outputable a => a -> String
Compat.printWithoutUniques) [DriverMessages]
closure_errs
        bad_units :: Set UnitId
bad_units = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
OS.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ [[UnitId]] -> [UnitId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnitId]] -> [UnitId]) -> [[UnitId]] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ do
            DriverMessage
x <- Bag DriverMessage -> [DriverMessage]
forall a. Bag a -> [a]
bagToList (Bag DriverMessage -> [DriverMessage])
-> Bag DriverMessage -> [DriverMessage]
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope DriverMessage -> DriverMessage)
-> Bag (MsgEnvelope DriverMessage) -> Bag DriverMessage
forall a b. (a -> b) -> Bag a -> Bag b
mapBag MsgEnvelope DriverMessage -> DriverMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic (Bag (MsgEnvelope DriverMessage) -> Bag DriverMessage)
-> Bag (MsgEnvelope DriverMessage) -> Bag DriverMessage
forall a b. (a -> b) -> a -> b
$ [Bag (MsgEnvelope DriverMessage)]
-> Bag (MsgEnvelope DriverMessage)
forall a. [Bag a] -> Bag a
unionManyBags ([Bag (MsgEnvelope DriverMessage)]
 -> Bag (MsgEnvelope DriverMessage))
-> [Bag (MsgEnvelope DriverMessage)]
-> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> a -> b
$ (DriverMessages -> Bag (MsgEnvelope DriverMessage))
-> [DriverMessages] -> [Bag (MsgEnvelope DriverMessage)]
forall a b. (a -> b) -> [a] -> [b]
map DriverMessages -> Bag (MsgEnvelope DriverMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Compat.getMessages [DriverMessages]
closure_errs
            DriverHomePackagesNotClosed [UnitId]
us <- DriverMessage -> [DriverMessage]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DriverMessage
x
            [UnitId] -> [[UnitId]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitId]
us
        isBad :: ComponentInfo -> Bool
isBad ComponentInfo
ci = (DynFlags -> UnitId
homeUnitId_ (ComponentInfo -> DynFlags
componentDynFlags ComponentInfo
ci)) UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`OS.member` Set UnitId
bad_units
#else
    let isBad = const False
        multi_errs = []
#endif
    -- Whenever we spin up a session on Linux, dynamically load libm.so.6
    -- in. We need this in case the binary is statically linked, in which
    -- case the interactive session will fail when trying to load
    -- ghc-prim, which happens whenever Template Haskell is being
    -- evaluated or haskell-language-server's eval plugin tries to run
    -- some code. If the binary is dynamically linked, then this will have
    -- no effect.
    -- See https://github.com/haskell/haskell-language-server/issues/221
    -- We need to do this after the call to setSessionDynFlags initialises
    -- the loader
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"linux") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      HscEnv -> IO ()
initObjLinker HscEnv
hscEnv'
      Maybe String
res <- HscEnv -> String -> IO (Maybe String)
loadDLL HscEnv
hscEnv' String
"libm.so.6"
      case Maybe String
res of
        Maybe String
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just String
err -> Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogDLLLoadError String
err

    [ComponentInfo]
-> (ComponentInfo
    -> IO
         ([TargetDetails],
          (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)))
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map UnitId ComponentInfo -> [ComponentInfo]
forall k a. Map k a -> [a]
Map.elems Map UnitId ComponentInfo
cis) ((ComponentInfo
  -> IO
       ([TargetDetails],
        (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)))
 -> IO
      [([TargetDetails],
        (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))])
-> (ComponentInfo
    -> IO
         ([TargetDetails],
          (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)))
-> IO
     [([TargetDetails],
       (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
forall a b. (a -> b) -> a -> b
$ \ComponentInfo
ci -> do
      let df :: DynFlags
df = ComponentInfo -> DynFlags
componentDynFlags ComponentInfo
ci
      let createHscEnvEq :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
createHscEnvEq = (HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq)
-> (String -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq)
-> Maybe String
-> HscEnv
-> [(UnitId, DynFlags)]
-> IO HscEnvEq
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths String -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq Maybe String
cradlePath
      HscEnv
thisEnv <- do
#if MIN_VERSION_ghc(9,3,0)
            -- In GHC 9.4 we have multi component support, and we have initialised all the units
            -- above.
            -- We just need to set the current unit here
            HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (DynFlags -> UnitId
homeUnitId_ DynFlags
df) HscEnv
hscEnv'
#else
            -- This initializes the units for GHC 9.2
            -- Add the options for the current component to the HscEnv
            -- We want to call `setSessionDynFlags` instead of `hscSetFlags`
            -- because `setSessionDynFlags` also initializes the package database,
            -- which we need for any changes to the package flags in the dynflags
            -- to be visible.
            -- See #2693
            evalGhcEnv hscEnv' $ do
              _ <- setSessionDynFlags df
              getSession
#endif
      HscEnvEq
henv <- HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
createHscEnvEq HscEnv
thisEnv ([UnitId] -> [DynFlags] -> [(UnitId, DynFlags)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UnitId]
uids [DynFlags]
dfs)
      let targetEnv :: ([FileDiagnostic], Maybe HscEnvEq)
targetEnv = (if ComponentInfo -> Bool
isBad ComponentInfo
ci then [FileDiagnostic]
multi_errs else [], HscEnvEq -> Maybe HscEnvEq
forall a. a -> Maybe a
Just HscEnvEq
henv)
          targetDepends :: DependencyInfo
targetDepends = ComponentInfo -> DependencyInfo
componentDependencyInfo ComponentInfo
ci
          res :: (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
res = ( ([FileDiagnostic], Maybe HscEnvEq)
targetEnv, DependencyInfo
targetDepends)
      Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) -> Log
LogNewComponentCache (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
res
      () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Target -> ()) -> [Target] -> ()
forall a. (a -> ()) -> [a] -> ()
forall (f :: * -> *) a. NFData1 f => (a -> ()) -> f a -> ()
liftRnf Target -> ()
forall a. a -> ()
rwhnf ([Target] -> ()) -> [Target] -> ()
forall a b. (a -> b) -> a -> b
$ ComponentInfo -> [Target]
componentTargets ComponentInfo
ci

      let mk :: Target -> IO [TargetDetails]
mk Target
t = [String]
-> [String]
-> TargetId
-> ([FileDiagnostic], Maybe HscEnvEq)
-> DependencyInfo
-> IO [TargetDetails]
fromTargetId (DynFlags -> [String]
importPaths DynFlags
df) [String]
exts (Target -> TargetId
targetId Target
t) ([FileDiagnostic], Maybe HscEnvEq)
targetEnv DependencyInfo
targetDepends
      [TargetDetails]
ctargets <- (Target -> IO [TargetDetails]) -> [Target] -> IO [TargetDetails]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Target -> IO [TargetDetails]
mk (ComponentInfo -> [Target]
componentTargets ComponentInfo
ci)

      ([TargetDetails],
 (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> IO
     ([TargetDetails],
      (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TargetDetails -> Target) -> [TargetDetails] -> [TargetDetails]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.nubOrdOn TargetDetails -> Target
targetTarget [TargetDetails]
ctargets, (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
res)

{- Note [Avoiding bad interface files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Originally, we set the cache directory for the various components once
on the first occurrence of the component.
This works fine if these components have no references to each other,
but you have components that depend on each other, the interface files are
updated for each component.
After restarting the session and only opening the component that depended
on the other, suddenly the interface files of this component are stale.
However, from the point of view of `ghcide`, they do not look stale,
thus, not regenerated and the IDE shows weird errors such as:
```
typecheckIface
Declaration for Rep_ClientRunFlags
Axiom branches Rep_ClientRunFlags:
  Failed to load interface for ‘Distribution.Simple.Flag’
  Use -v to see a list of the files searched for.
```
and
```
expectJust checkFamInstConsistency
CallStack (from HasCallStack):
  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes
  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
```

To mitigate this, we set the cache directory for each component dependent
on the components of the current `HscEnv`, additionally to the component options
of the respective components.
Assume two components, c1, c2, where c2 depends on c1, and the options of the
respective components are co1, co2.
If we want to load component c2, followed by c1, we set the cache directory for
each component in this way:

  * Load component c2
    * (Cache Directory State)
        - name of c2 + co2
  * Load component c1
    * (Cache Directory State)
        - name of c2 + name of c1 + co2
        - name of c2 + name of c1 + co1

Overall, we created three cache directories. If we opened c1 first, then we
create a fourth cache directory.
This makes sure that interface files are always correctly updated.

Since this causes a lot of recompilation, we only update the cache-directory,
if the dependencies of a component have really changed.
E.g. when you load two executables, they can not depend on each other. They
should be filtered out, such that we dont have to re-compile everything.
-}

-- | Set the cache-directory based on the ComponentOptions and a list of
-- internal packages.
-- For the exact reason, see Note [Avoiding bad interface files].
setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags
setCacheDirs :: forall (m :: * -> *).
MonadUnliftIO m =>
Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags
setCacheDirs Recorder (WithPriority Log)
recorder CacheDirs{Maybe String
hiCacheDir :: CacheDirs -> Maybe String
hieCacheDir :: CacheDirs -> Maybe String
oCacheDir :: CacheDirs -> Maybe String
hiCacheDir :: Maybe String
hieCacheDir :: Maybe String
oCacheDir :: Maybe String
..} DynFlags
dflags = do
    Recorder (WithPriority Log) -> Priority -> Log -> m ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> m ()) -> Log -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogInterfaceFilesCacheDir (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
cacheDir Maybe String
hiCacheDir)
    DynFlags -> m DynFlags
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> m DynFlags) -> DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags
          DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& (DynFlags -> DynFlags)
-> (String -> DynFlags -> DynFlags)
-> Maybe String
-> DynFlags
-> DynFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DynFlags -> DynFlags
forall a. a -> a
id String -> DynFlags -> DynFlags
setHiDir Maybe String
hiCacheDir
          DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& (DynFlags -> DynFlags)
-> (String -> DynFlags -> DynFlags)
-> Maybe String
-> DynFlags
-> DynFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DynFlags -> DynFlags
forall a. a -> a
id String -> DynFlags -> DynFlags
setHieDir Maybe String
hieCacheDir
          DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& (DynFlags -> DynFlags)
-> (String -> DynFlags -> DynFlags)
-> Maybe String
-> DynFlags
-> DynFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DynFlags -> DynFlags
forall a. a -> a
id String -> DynFlags -> DynFlags
setODir Maybe String
oCacheDir

-- See Note [Multi Cradle Dependency Info]
type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]
-- | Maps a "hie.yaml" location to all its Target Filepaths and options.
type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
-- | Maps a Filepath to its respective "hie.yaml" location.
-- It aims to be the reverse of 'FlagsMap'.
type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath)

-- This is pristine information about a component
data RawComponentInfo = RawComponentInfo
  { RawComponentInfo -> UnitId
rawComponentUnitId         :: UnitId
  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.
  -- We do not want to use them unprocessed.
  , RawComponentInfo -> DynFlags
rawComponentDynFlags       :: DynFlags
  -- | All targets of this components.
  , RawComponentInfo -> [Target]
rawComponentTargets        :: [GHC.Target]
  -- | Filepath which caused the creation of this component
  , RawComponentInfo -> NormalizedFilePath
rawComponentFP             :: NormalizedFilePath
  -- | Component Options used to load the component.
  , RawComponentInfo -> ComponentOptions
rawComponentCOptions       :: ComponentOptions
  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
  -- to last modification time. See Note [Multi Cradle Dependency Info].
  , RawComponentInfo -> DependencyInfo
rawComponentDependencyInfo :: DependencyInfo
  }

-- This is processed information about the component, in particular the dynflags will be modified.
data ComponentInfo = ComponentInfo
  { ComponentInfo -> UnitId
componentUnitId         :: UnitId
  -- | Processed DynFlags. Does not contain inplace packages such as local
  -- libraries. Can be used to actually load this Component.
  , ComponentInfo -> DynFlags
componentDynFlags       :: DynFlags
  -- | Internal units, such as local libraries, that this component
  -- is loaded with. These have been extracted from the original
  -- ComponentOptions.
  , ComponentInfo -> [UnitId]
componentInternalUnits  :: [UnitId]
  -- | All targets of this components.
  , ComponentInfo -> [Target]
componentTargets        :: [GHC.Target]
  -- | Filepath which caused the creation of this component
  , ComponentInfo -> NormalizedFilePath
componentFP             :: NormalizedFilePath
  -- | Component Options used to load the component.
  , ComponentInfo -> ComponentOptions
componentCOptions       :: ComponentOptions
  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
  -- to last modification time. See Note [Multi Cradle Dependency Info]
  , ComponentInfo -> DependencyInfo
componentDependencyInfo :: DependencyInfo
  }

-- | Check if any dependency has been modified lately.
checkDependencyInfo :: DependencyInfo -> IO Bool
checkDependencyInfo :: DependencyInfo -> IO Bool
checkDependencyInfo DependencyInfo
old_di = do
  DependencyInfo
di <- [String] -> IO DependencyInfo
getDependencyInfo (DependencyInfo -> [String]
forall k a. Map k a -> [k]
Map.keys DependencyInfo
old_di)
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyInfo
di DependencyInfo -> DependencyInfo -> Bool
forall a. Eq a => a -> a -> Bool
== DependencyInfo
old_di)

-- Note [Multi Cradle Dependency Info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Why do we implement our own file modification tracking here?
-- The primary reason is that the custom caching logic is quite complicated and going into shake
-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to
-- use shake rules rather than IO but eventually gave up.

-- | Computes a mapping from a filepath to its latest modification date.
-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead
-- of letting shake take care of it.
getDependencyInfo :: [FilePath] -> IO DependencyInfo
getDependencyInfo :: [String] -> IO DependencyInfo
getDependencyInfo [String]
fs = [(String, Maybe UTCTime)] -> DependencyInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Maybe UTCTime)] -> DependencyInfo)
-> IO [(String, Maybe UTCTime)] -> IO DependencyInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (String, Maybe UTCTime))
-> [String] -> IO [(String, Maybe UTCTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (String, Maybe UTCTime)
do_one [String]
fs

  where
    safeTryIO :: IO a -> IO (Either IOException a)
    safeTryIO :: forall a. IO a -> IO (Either IOException a)
safeTryIO = IO a -> IO (Either IOException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try

    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
    do_one :: String -> IO (String, Maybe UTCTime)
do_one String
fp = (String
fp,) (Maybe UTCTime -> (String, Maybe UTCTime))
-> (Either IOException UTCTime -> Maybe UTCTime)
-> Either IOException UTCTime
-> (String, Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either IOException UTCTime -> Maybe UTCTime
forall a b. Either a b -> Maybe b
eitherToMaybe (Either IOException UTCTime -> (String, Maybe UTCTime))
-> IO (Either IOException UTCTime) -> IO (String, Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
safeTryIO (String -> IO UTCTime
getModificationTime String
fp)

-- | This function removes all the -package flags which refer to packages we
-- are going to deal with ourselves. For example, if a executable depends
-- on a library component, then this function will remove the library flag
-- from the package flags for the executable
--
-- There are several places in GHC (for example the call to hptInstances in
-- tcRnImports) which assume that all modules in the HPT have the same unit
-- ID. Therefore we create a fake one and give them all the same unit id.
_removeInplacePackages --Only used in ghc < 9.4
    :: UnitId     -- ^ fake uid to use for our internal component
    -> [UnitId]
    -> DynFlags
    -> (DynFlags, [UnitId])
_removeInplacePackages :: UnitId -> [UnitId] -> DynFlags -> (DynFlags, [UnitId])
_removeInplacePackages UnitId
fake_uid [UnitId]
us DynFlags
df = (UnitId -> DynFlags -> DynFlags
setHomeUnitId_ UnitId
fake_uid (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
                                       DynFlags
df { packageFlags = ps }, [UnitId]
uids)
  where
    ([UnitId]
uids, [PackageFlag]
ps) = [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag])
Compat.filterInplaceUnits [UnitId]
us (DynFlags -> [PackageFlag]
packageFlags DynFlags
df)

-- | Memoize an IO function, with the characteristics:
--
--   * If multiple people ask for a result simultaneously, make sure you only compute it once.
--
--   * If there are exceptions, repeatedly reraise them.
--
--   * If the caller is aborted (async exception) finish computing it anyway.
memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO :: forall a b. Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO a -> IO b
op = do
    Var (Map a (IO b))
ref <- Map a (IO b) -> IO (Var (Map a (IO b)))
forall a. a -> IO (Var a)
newVar Map a (IO b)
forall k a. Map k a
Map.empty
    (a -> IO b) -> IO (a -> IO b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> IO b) -> IO (a -> IO b)) -> (a -> IO b) -> IO (a -> IO b)
forall a b. (a -> b) -> a -> b
$ \a
k -> IO (IO b) -> IO b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO b) -> IO b) -> IO (IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ IO (IO b) -> IO (IO b)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (IO b) -> IO (IO b)) -> IO (IO b) -> IO (IO b)
forall a b. (a -> b) -> a -> b
$ Var (Map a (IO b))
-> (Map a (IO b) -> IO (Map a (IO b), IO b)) -> IO (IO b)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (Map a (IO b))
ref ((Map a (IO b) -> IO (Map a (IO b), IO b)) -> IO (IO b))
-> (Map a (IO b) -> IO (Map a (IO b), IO b)) -> IO (IO b)
forall a b. (a -> b) -> a -> b
$ \Map a (IO b)
mp ->
        case a -> Map a (IO b) -> Maybe (IO b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a (IO b)
mp of
            Maybe (IO b)
Nothing -> do
                IO b
res <- IO b -> IO (IO b)
forall a. IO a -> IO (IO a)
onceFork (IO b -> IO (IO b)) -> IO b -> IO (IO b)
forall a b. (a -> b) -> a -> b
$ a -> IO b
op a
k
                (Map a (IO b), IO b) -> IO (Map a (IO b), IO b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO b -> Map a (IO b) -> Map a (IO b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
k IO b
res Map a (IO b)
mp, IO b
res)
            Just IO b
res -> (Map a (IO b), IO b) -> IO (Map a (IO b), IO b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map a (IO b)
mp, IO b
res)

unit_flags :: [Flag (CmdLineP [String])]
unit_flags :: [Flag (CmdLineP [String])]
unit_flags = [String -> OptKind (CmdLineP [String]) -> Flag (CmdLineP [String])
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag String
"unit"  ((String -> EwM (CmdLineP [String]) ())
-> OptKind (CmdLineP [String])
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
SepArg String -> EwM (CmdLineP [String]) ()
addUnit)]

addUnit :: String -> EwM (CmdLineP [String]) ()
addUnit :: String -> EwM (CmdLineP [String]) ()
addUnit String
unit_str = CmdLineP [String] () -> EwM (CmdLineP [String]) ()
forall (m :: * -> *) a. Monad m => m a -> EwM m a
liftEwM (CmdLineP [String] () -> EwM (CmdLineP [String]) ())
-> CmdLineP [String] () -> EwM (CmdLineP [String]) ()
forall a b. (a -> b) -> a -> b
$ do
  [String]
units <- CmdLineP [String] [String]
forall s. CmdLineP s s
getCmdLineState
  [String] -> CmdLineP [String] ()
forall s. s -> CmdLineP s ()
putCmdLineState (String
unit_str String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
units)

-- | Throws if package flags are unsatisfiable
setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target]))
setOptions :: forall (m :: * -> *).
GhcMonad m =>
NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> m (NonEmpty (DynFlags, [Target]))
setOptions NormalizedFilePath
cfp (ComponentOptions [String]
theOpts String
compRoot [String]
_) DynFlags
dflags = do
    (([Located String]
theOpts',[Err]
_errs,[Warn]
_warns),[String]
units) <- [Flag (CmdLineP [String])]
-> [String]
-> [Located String]
-> m (([Located String], [Err], [Warn]), [String])
forall s (m :: * -> *).
MonadIO m =>
[Flag (CmdLineP s)]
-> s
-> [Located String]
-> m (([Located String], [Err], [Warn]), s)
processCmdLineP [Flag (CmdLineP [String])]
unit_flags [] ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall e. e -> Located e
noLoc [String]
theOpts)
    case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [String]
units of
      Just NonEmpty String
us -> NonEmpty String -> m (NonEmpty (DynFlags, [Target]))
initMulti NonEmpty String
us
      Maybe (NonEmpty String)
Nothing -> do
        (DynFlags
df, [Target]
targets) <- [String] -> m (DynFlags, [Target])
initOne ((Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
theOpts')
        -- A special target for the file which caused this wonderful
        -- component to be created. In case the cradle doesn't list all the targets for
        -- the component, in which case things will be horribly broken anyway.
        -- Otherwise, we will immediately attempt to reload this module which
        -- causes an infinite loop and high CPU usage.
        --
        -- We don't do this when we have multiple components, because each
        -- component better list all targets or there will be anarchy.
        -- It is difficult to know which component to add our file to in
        -- that case.
        -- Multi unit arguments are likely to come from cabal, which
        -- does list all targets.
        String
abs_fp <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
cfp)
        let special_target :: Target
special_target = DynFlags -> String -> Target
Compat.mkSimpleTarget DynFlags
df String
abs_fp
        NonEmpty (DynFlags, [Target]) -> m (NonEmpty (DynFlags, [Target]))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (DynFlags, [Target])
 -> m (NonEmpty (DynFlags, [Target])))
-> NonEmpty (DynFlags, [Target])
-> m (NonEmpty (DynFlags, [Target]))
forall a b. (a -> b) -> a -> b
$ (DynFlags
df, Target
special_target Target -> [Target] -> [Target]
forall a. a -> [a] -> [a]
: [Target]
targets) (DynFlags, [Target])
-> [(DynFlags, [Target])] -> NonEmpty (DynFlags, [Target])
forall a. a -> [a] -> NonEmpty a
:| []
    where
      initMulti :: NonEmpty String -> m (NonEmpty (DynFlags, [Target]))
initMulti NonEmpty String
unitArgFiles =
        NonEmpty String
-> (String -> m (DynFlags, [Target]))
-> m (NonEmpty (DynFlags, [Target]))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty String
unitArgFiles ((String -> m (DynFlags, [Target]))
 -> m (NonEmpty (DynFlags, [Target])))
-> (String -> m (DynFlags, [Target]))
-> m (NonEmpty (DynFlags, [Target]))
forall a b. (a -> b) -> a -> b
$ \String
f -> do
          [String]
args <- IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
expandResponse [String
f]
          [String] -> m (DynFlags, [Target])
initOne [String]
args
      initOne :: [String] -> m (DynFlags, [Target])
initOne [String]
this_opts = do
        (DynFlags
dflags', [Target]
targets') <- [String] -> DynFlags -> m (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[String] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [String]
this_opts DynFlags
dflags
        let dflags'' :: DynFlags
dflags'' =
#if MIN_VERSION_ghc(9,3,0)
                case UnitId -> String
unitIdString (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags') of
                     -- cabal uses main for the unit id of all executable packages
                     -- This makes multi-component sessions confused about what
                     -- options to use for that component.
                     -- Solution: hash the options and use that as part of the unit id
                     -- This works because there won't be any dependencies on the
                     -- executable unit.
                     String
"main" ->
                       let hash :: String
hash = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString
H.finalize (Ctx -> ByteString) -> Ctx -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> [ByteString] -> Ctx
H.updates Ctx
H.init ((String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
B.pack ([String] -> [ByteString]) -> [String] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [String]
this_opts)
                           hashed_uid :: UnitId
hashed_uid = Unit -> UnitId
Compat.toUnitId (String -> Unit
Compat.stringToUnit (String
"main-"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
hash))
                       in UnitId -> DynFlags -> DynFlags
setHomeUnitId_ UnitId
hashed_uid DynFlags
dflags'
                     String
_ -> DynFlags
dflags'
#else
                dflags'
#endif

        let targets :: [Target]
targets = String -> [Target] -> [Target]
makeTargetsAbsolute String
root [Target]
targets'
            root :: String
root = case DynFlags -> Maybe String
workingDirectory DynFlags
dflags'' of
              Maybe String
Nothing   -> String
compRoot
              Just String
wdir -> String
compRoot String -> ShowS
</> String
wdir
        let dflags''' :: DynFlags
dflags''' =
              String -> DynFlags -> DynFlags
setWorkingDirectory String
root (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
disableWarningsAsErrors (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              -- disabled, generated directly by ghcide instead
              (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_WriteInterface (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              -- disabled, generated directly by ghcide instead
              -- also, it can confuse the interface stale check
              DynFlags -> DynFlags
dontWriteHieFiles (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
setIgnoreInterfacePragmas (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
setBytecodeLinkerOptions (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
disableOptimisation (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
Compat.setUpTypedHoles (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              String -> DynFlags -> DynFlags
makeDynFlagsAbsolute String
compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
              DynFlags
dflags''
        -- initPackages parses the -package flags and
        -- sets up the visibility for each component.
        -- Throws if a -package flag cannot be satisfied.
        -- This only works for GHC <9.2
        -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which
        -- is done later in newComponentCache
        DynFlags
final_flags <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ IO DynFlags -> IO DynFlags
forall a. IO a -> IO a
wrapPackageSetupException (IO DynFlags -> IO DynFlags) -> IO DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO DynFlags
Compat.oldInitUnits DynFlags
dflags'''
        (DynFlags, [Target]) -> m (DynFlags, [Target])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
final_flags, [Target]
targets)

setIgnoreInterfacePragmas :: DynFlags -> DynFlags
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
setIgnoreInterfacePragmas DynFlags
df =
    DynFlags -> GeneralFlag -> DynFlags
gopt_set (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
df GeneralFlag
Opt_IgnoreInterfacePragmas) GeneralFlag
Opt_IgnoreOptimChanges

disableOptimisation :: DynFlags -> DynFlags
disableOptimisation :: DynFlags -> DynFlags
disableOptimisation DynFlags
df = Int -> DynFlags -> DynFlags
updOptLevel Int
0 DynFlags
df

setHiDir :: FilePath -> DynFlags -> DynFlags
setHiDir :: String -> DynFlags -> DynFlags
setHiDir String
f DynFlags
d =
    -- override user settings to avoid conflicts leading to recompilation
    DynFlags
d { hiDir      = Just f}

setODir :: FilePath -> DynFlags -> DynFlags
setODir :: String -> DynFlags -> DynFlags
setODir String
f DynFlags
d =
    -- override user settings to avoid conflicts leading to recompilation
    DynFlags
d { objectDir = Just f}

getCacheDirsDefault :: String -> [String] -> IO CacheDirs
getCacheDirsDefault :: String -> [String] -> IO CacheDirs
getCacheDirsDefault String
prefix [String]
opts = do
    Maybe String
dir <- String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache (String
cacheDir String -> ShowS
</> String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opts_hash)
    CacheDirs -> IO CacheDirs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CacheDirs -> IO CacheDirs) -> CacheDirs -> IO CacheDirs
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> Maybe String -> CacheDirs
CacheDirs Maybe String
dir Maybe String
dir Maybe String
dir
    where
        -- Create a unique folder per set of different GHC options, assuming that each different set of
        -- GHC options will create incompatible interface files.
        opts_hash :: String
opts_hash = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString
H.finalize (Ctx -> ByteString) -> Ctx -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> [ByteString] -> Ctx
H.updates Ctx
H.init ((String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
B.pack [String]
opts)

-- | Sub directory for the cache path
cacheDir :: String
cacheDir :: String
cacheDir = String
"ghcide"

----------------------------------------------------------------------------------------------------

data PackageSetupException
    = PackageSetupException
        { PackageSetupException -> String
message     :: !String
        }
    | GhcVersionMismatch
        { PackageSetupException -> Version
compileTime :: !Version
        , PackageSetupException -> Version
runTime     :: !Version
        }
    | PackageCheckFailed !NotCompatibleReason
    deriving (PackageSetupException -> PackageSetupException -> Bool
(PackageSetupException -> PackageSetupException -> Bool)
-> (PackageSetupException -> PackageSetupException -> Bool)
-> Eq PackageSetupException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PackageSetupException -> PackageSetupException -> Bool
== :: PackageSetupException -> PackageSetupException -> Bool
$c/= :: PackageSetupException -> PackageSetupException -> Bool
/= :: PackageSetupException -> PackageSetupException -> Bool
Eq, Int -> PackageSetupException -> ShowS
[PackageSetupException] -> ShowS
PackageSetupException -> String
(Int -> PackageSetupException -> ShowS)
-> (PackageSetupException -> String)
-> ([PackageSetupException] -> ShowS)
-> Show PackageSetupException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageSetupException -> ShowS
showsPrec :: Int -> PackageSetupException -> ShowS
$cshow :: PackageSetupException -> String
show :: PackageSetupException -> String
$cshowList :: [PackageSetupException] -> ShowS
showList :: [PackageSetupException] -> ShowS
Show, Typeable)

instance Exception PackageSetupException

-- | Wrap any exception as a 'PackageSetupException'
wrapPackageSetupException :: IO a -> IO a
wrapPackageSetupException :: forall a. IO a -> IO a
wrapPackageSetupException = (SomeException -> IO a) -> IO a -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \case
  SomeException
e | Just (PackageSetupException
pkgE :: PackageSetupException) <- SomeException -> Maybe PackageSetupException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> PackageSetupException -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO PackageSetupException
pkgE
  SomeException
e -> (PackageSetupException -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (PackageSetupException -> IO a)
-> (SomeException -> PackageSetupException)
-> SomeException
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PackageSetupException
PackageSetupException (String -> PackageSetupException)
-> (SomeException -> String)
-> SomeException
-> PackageSetupException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) SomeException
e

showPackageSetupException :: PackageSetupException -> String
showPackageSetupException :: PackageSetupException -> String
showPackageSetupException GhcVersionMismatch{Version
compileTime :: PackageSetupException -> Version
runTime :: PackageSetupException -> Version
compileTime :: Version
runTime :: Version
..} = [String] -> String
unwords
    [String
"ghcide compiled against GHC"
    ,Version -> String
showVersion Version
compileTime
    ,String
"but currently using"
    ,Version -> String
showVersion Version
runTime
    ,String
"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."
    ]
showPackageSetupException PackageSetupException{String
message :: PackageSetupException -> String
message :: String
..} = [String] -> String
unwords
    [ String
"ghcide compiled by GHC", Version -> String
showVersion Version
compilerVersion
    , String
"failed to load packages:", String
message String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
    , String
"\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
showPackageSetupException (PackageCheckFailed PackageVersionMismatch{String
Version
compileTime :: Version
runTime :: Version
packageName :: String
$sel:compileTime:PackageVersionMismatch :: NotCompatibleReason -> Version
$sel:runTime:PackageVersionMismatch :: NotCompatibleReason -> Version
$sel:packageName:PackageVersionMismatch :: NotCompatibleReason -> String
..}) = [String] -> String
unwords
    [String
"ghcide compiled with package "
    , String
packageName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
compileTime
    ,String
"but project uses package"
    , String
packageName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
runTime
    ,String
"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
    ]
showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{String
Version
$sel:compileTime:PackageVersionMismatch :: NotCompatibleReason -> Version
compileTimeAbi :: String
runTimeAbi :: String
compileTime :: Version
$sel:compileTimeAbi:PackageVersionMismatch :: NotCompatibleReason -> String
$sel:runTimeAbi:PackageVersionMismatch :: NotCompatibleReason -> String
..}) = [String] -> String
unwords
    [String
"ghcide compiled with base-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
compileTime String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
compileTimeAbi
    ,String
"but project uses base-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
compileTime String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
runTimeAbi
    ,String
"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
    ]

renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderPackageSetupException :: String -> PackageSetupException -> FileDiagnostic
renderPackageSetupException String
fp PackageSetupException
e =
    Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> FileDiagnostic
forall a.
Maybe Text
-> Maybe DiagnosticSeverity
-> a
-> Text
-> (a, ShowDiagnostic, Diagnostic)
ideErrorWithSource (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cradle") (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error) (String -> NormalizedFilePath
toNormalizedFilePath' String
fp) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageSetupException -> String
showPackageSetupException PackageSetupException
e)