{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Session
(SessionLoadingOptions(..)
,CacheDirs(..)
,loadSessionWithOptions
,setInitialDynFlags
,getHieDbLoc
,retryOnSqliteBusy
,retryOnException
,Log(..)
,runWithDb
) where
import Control.Concurrent.Strict
import Control.Exception.Safe as Safe
import Control.Monad
import Control.Monad.Extra as 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, knownTargets,
withHieDb)
import qualified Development.IDE.GHC.Compat as Compat
import Development.IDE.GHC.Compat.CmdLine
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 qualified Development.IDE.Session.Implicit as GhcIde
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.ResponseFile
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 Ide.Types (SessionLoadingPreferenceConfig (..),
sessionLoading)
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 Control.Monad.Trans.Cont (ContT (ContT, runContT))
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.Core.WorkerThread (awaitRunInThread,
withWorkerQueue)
import Development.IDE.Session.Diagnostics (renderCradleError)
import Development.IDE.Types.Shake (WithHieDb,
WithHieDbShield (..),
toNoFileKey)
import HieDb.Create
import HieDb.Types
import HieDb.Utils
import Ide.PluginUtils (toAbsolute)
import qualified System.Random as Random
import System.Random (RandomGen)
import Text.ParserCombinators.ReadP (readP_to_S)
#if MIN_VERSION_ghc(9,3,0)
import qualified Data.Set as OS
import qualified Development.IDE.GHC.Compat.Util as Compat
import GHC.Data.Graph.Directed
import GHC.Data.Bag
import GHC.Driver.Env (hsc_all_home_unit_ids)
import GHC.Driver.Errors.Types
import GHC.Types.Error (errMsgDiagnostic,
singleMessage)
import GHC.Unit.State
#endif
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, String))
| LogCradle !(Cradle Void)
| LogNoneCradleFound FilePath
| LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
| LogHieBios HieBios.Log
| LogSessionLoadingChanged
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, 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, String) -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Either [CradleError] (ComponentOptions, String, 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
Log
LogSessionLoadingChanged ->
Doc ann
"Session Loading config changed, reloading the full session."
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)
, SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
loadCradle :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
, SessionLoadingOptions -> String -> [String] -> IO CacheDirs
getCacheDirs :: String -> [String] -> IO CacheDirs
, 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
#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
}
loadWithImplicitCradle
:: Recorder (WithPriority Log)
-> Maybe FilePath
-> FilePath
-> 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
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
retryOnException
:: (MonadIO m, MonadCatch m, RandomGen g, Exception e)
=> (e -> Maybe e)
-> Recorder (WithPriority Log)
-> Int
-> Int
-> Int
-> g
-> m a
-> 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
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
oneSecond :: Int
oneSecond :: Int
oneSecond = Int
1000000
oneMillisecond :: Int
oneMillisecond :: Int
oneMillisecond = Int
1000
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)
runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)
runWithDb :: Recorder (WithPriority Log)
-> String -> ContT () IO (WithHieDbShield, IndexQueue)
runWithDb Recorder (WithPriority Log)
recorder String
fp = (((WithHieDbShield, IndexQueue) -> IO ()) -> IO ())
-> ContT () IO (WithHieDbShield, IndexQueue)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((WithHieDbShield, IndexQueue) -> IO ()) -> IO ())
-> ContT () IO (WithHieDbShield, IndexQueue))
-> (((WithHieDbShield, IndexQueue) -> IO ()) -> IO ())
-> ContT () IO (WithHieDbShield, IndexQueue)
forall a b. (a -> b) -> a -> b
$ \(WithHieDbShield, IndexQueue) -> IO ()
k -> do
StdGen
rng <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
Random.newStdGen
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
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
()
_ <- (HieDb -> IO ()) -> IO ()
WithHieDb
withWriteDbRetryable HieDb -> IO ()
deleteMissingRealFiles
Int
_ <- (HieDb -> IO Int) -> IO Int
WithHieDb
withWriteDbRetryable HieDb -> IO Int
garbageCollectTypeNames
ContT () IO IndexQueue -> (IndexQueue -> IO ()) -> IO ()
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (((((HieDb -> IO ()) -> IO ()) -> IO ()) -> IO ())
-> ContT () IO IndexQueue
forall t a. (t -> IO a) -> ContT () IO (TQueue t)
withWorkerQueue (((HieDb -> IO ()) -> IO ())
-> (((HieDb -> IO ()) -> IO ()) -> IO ()) -> IO ()
writer (HieDb -> IO ()) -> IO ()
WithHieDb
withWriteDbRetryable)) ((IndexQueue -> IO ()) -> IO ()) -> (IndexQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IndexQueue
chan ->
String -> (HieDb -> IO ()) -> IO ()
forall a. String -> (HieDb -> IO a) -> IO a
withHieDb String
fp (\HieDb
readDb -> (WithHieDbShield, IndexQueue) -> IO ()
k (WithHieDb -> WithHieDbShield
WithHieDbShield (WithHieDb -> WithHieDbShield) -> WithHieDb -> WithHieDbShield
forall a b. (a -> b) -> a -> b
$ 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
writer :: ((HieDb -> IO ()) -> IO ())
-> (((HieDb -> IO ()) -> IO ()) -> IO ()) -> IO ()
writer (HieDb -> IO ()) -> IO ()
withHieDbRetryable ((HieDb -> IO ()) -> IO ()) -> IO ()
l = do
((HieDb -> IO ()) -> IO ()) -> IO ()
l (HieDb -> IO ()) -> IO ()
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)
loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)
loadSessionWithOptions :: Recorder (WithPriority Log)
-> SessionLoadingOptions
-> String
-> TQueue (IO ())
-> 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
rootDir TQueue (IO ())
que = do
let toAbsolutePath :: ShowS
toAbsolutePath = String -> ShowS
toAbsolute String
rootDir
IORef [String]
cradle_files <- [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
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)
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)
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)
Var Int
version <- Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar Int
0
Var (Maybe SessionLoadingPreferenceConfig)
biosSessionLoadingVar <- Maybe SessionLoadingPreferenceConfig
-> IO (Var (Maybe SessionLoadingPreferenceConfig))
forall a. a -> IO (Var a)
newVar Maybe SessionLoadingPreferenceConfig
forall a. Maybe a
Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))
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)
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
let res' :: Maybe String
res' = ShowS
toAbsolutePath ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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'
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
Config
clientConfig <- Action Config
getClientConfigAction
extras :: ShakeExtras
extras@ShakeExtras{VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
restartShakeSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
$sel:restartShakeSession:ShakeExtras :: ShakeExtras
-> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
restartShakeSession, NameCache
ideNc :: NameCache
$sel:ideNc:ShakeExtras :: ShakeExtras -> NameCache
ideNc, TVar (Hashed KnownTargets)
knownTargetsVar :: TVar (Hashed KnownTargets)
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
knownTargetsVar, Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv
} <- Action ShakeExtras
getShakeExtras
let invalidateShakeCache :: IO Key
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
Key -> IO Key
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> IO Key) -> Key -> IO Key
forall a b. (a -> b) -> a -> b
$ GhcSessionIO -> Key
forall k. (Show k, Typeable k, Eq k, Hashable k) => k -> Key
toNoFileKey GhcSessionIO
GhcSessionIO
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
let extendKnownTargets :: [TargetDetails] -> IO Key
extendKnownTargets [TargetDetails]
newTargets = do
[(Target, HashSet NormalizedFilePath)]
knownTargets <- [TargetDetails]
-> (TargetDetails -> IO [(Target, HashSet NormalizedFilePath)])
-> IO [(Target, HashSet NormalizedFilePath)]
forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM [TargetDetails]
newTargets ((TargetDetails -> IO [(Target, HashSet NormalizedFilePath)])
-> IO [(Target, HashSet NormalizedFilePath)])
-> (TargetDetails -> IO [(Target, HashSet NormalizedFilePath)])
-> IO [(Target, HashSet 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
[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, HashSet NormalizedFilePath)]
-> IO [(Target, HashSet NormalizedFilePath)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Target, HashSet NormalizedFilePath)]
-> IO [(Target, HashSet NormalizedFilePath)])
-> [(Target, HashSet NormalizedFilePath)]
-> IO [(Target, HashSet NormalizedFilePath)]
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> (Target, HashSet NormalizedFilePath))
-> [NormalizedFilePath] -> [(Target, HashSet NormalizedFilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\NormalizedFilePath
fp -> (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
fp, NormalizedFilePath -> HashSet NormalizedFilePath
forall a. Hashable a => a -> HashSet a
Set.singleton 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, HashSet NormalizedFilePath)]
-> IO [(Target, HashSet NormalizedFilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Target
targetTarget, [NormalizedFilePath] -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [NormalizedFilePath]
found)]
Maybe KnownTargets
hasUpdate <- STM (Maybe KnownTargets) -> IO (Maybe KnownTargets)
forall a. STM a -> IO a
atomically (STM (Maybe KnownTargets) -> IO (Maybe KnownTargets))
-> STM (Maybe KnownTargets) -> IO (Maybe KnownTargets)
forall a b. (a -> b) -> a -> b
$ do
Hashed KnownTargets
known <- TVar (Hashed KnownTargets) -> STM (Hashed KnownTargets)
forall a. TVar a -> STM a
readTVar TVar (Hashed KnownTargets)
knownTargetsVar
let known' :: Hashed KnownTargets
known' = ((KnownTargets -> KnownTargets)
-> Hashed KnownTargets -> Hashed KnownTargets)
-> Hashed KnownTargets
-> (KnownTargets -> KnownTargets)
-> Hashed KnownTargets
forall a b c. (a -> b -> c) -> b -> a -> c
flip (KnownTargets -> KnownTargets)
-> Hashed KnownTargets -> Hashed KnownTargets
forall b a. Hashable b => (a -> b) -> Hashed a -> Hashed b
mapHashed Hashed KnownTargets
known ((KnownTargets -> KnownTargets) -> Hashed KnownTargets)
-> (KnownTargets -> KnownTargets) -> Hashed KnownTargets
forall a b. (a -> b) -> a -> b
$ \KnownTargets
k -> KnownTargets -> KnownTargets -> KnownTargets
unionKnownTargets KnownTargets
k ([(Target, HashSet NormalizedFilePath)] -> KnownTargets
mkKnownTargets [(Target, HashSet NormalizedFilePath)]
knownTargets)
hasUpdate :: Maybe KnownTargets
hasUpdate = if Hashed KnownTargets
known Hashed KnownTargets -> Hashed KnownTargets -> Bool
forall a. Eq a => a -> a -> Bool
/= Hashed KnownTargets
known' then KnownTargets -> Maybe KnownTargets
forall a. a -> Maybe a
Just (Hashed KnownTargets -> KnownTargets
forall a. Hashed a -> a
unhashed Hashed KnownTargets
known') else Maybe KnownTargets
forall a. Maybe a
Nothing
TVar (Hashed KnownTargets) -> Hashed KnownTargets -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Hashed KnownTargets)
knownTargetsVar Hashed KnownTargets
known'
Maybe KnownTargets -> STM (Maybe KnownTargets)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe KnownTargets
hasUpdate
Maybe KnownTargets -> (KnownTargets -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe KnownTargets
hasUpdate ((KnownTargets -> IO ()) -> IO ())
-> (KnownTargets -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \KnownTargets
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 (KnownTargets -> HashMap Target (HashSet NormalizedFilePath)
targetMap KnownTargets
x)
Key -> IO Key
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> IO Key) -> Key -> IO Key
forall a b. (a -> b) -> a -> b
$ GetKnownTargets -> Key
forall k. (Show k, Typeable k, Eq k, Hashable k) => k -> Key
toNoFileKey GetKnownTargets
GetKnownTargets
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
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
-> String
-> Ghc (NonEmpty (DynFlags, [Target]))
forall (m :: * -> *).
GhcMonad m =>
NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> String
-> m (NonEmpty (DynFlags, [Target]))
setOptions NormalizedFilePath
cfp ComponentOptions
opts (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) String
rootDir
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
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
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
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]
-> Maybe [RawComponentInfo] -> [RawComponentInfo]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [RawComponentInfo]
oldDeps
_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
#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
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
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
}
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
HscEnv
hscEnv <- NameCache -> String -> IO HscEnv
emptyHscEnv NameCache
ideNc String
_libDir
let new_cache :: [ComponentInfo]
-> [ComponentInfo] -> String -> IO [[TargetDetails]]
new_cache = Recorder (WithPriority Log)
-> [String]
-> Maybe String
-> NormalizedFilePath
-> HscEnv
-> [ComponentInfo]
-> [ComponentInfo]
-> String
-> IO [[TargetDetails]]
newComponentCache Recorder (WithPriority Log)
recorder [String]
optExtensions Maybe String
hieYaml NormalizedFilePath
_cfp HscEnv
hscEnv
[[TargetDetails]]
all_target_details <- [ComponentInfo]
-> [ComponentInfo] -> String -> IO [[TargetDetails]]
new_cache [ComponentInfo]
old_deps [ComponentInfo]
new_deps String
rootDir
DependencyInfo
this_dep_info <- [String] -> IO DependencyInfo
getDependencyInfo ([String] -> IO DependencyInfo) -> [String] -> IO DependencyInfo
forall a b. (a -> b) -> a -> b
$ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
hieYaml
let ([TargetDetails]
all_targets, HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags_map, (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_options)
= 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 NormalizedFilePath
_cfp HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
flags_map' of
Just (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this -> ([TargetDetails]
all_targets', HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
flags_map', (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this)
Maybe (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
Nothing -> (TargetDetails
this_target_details TargetDetails -> [TargetDetails] -> [TargetDetails]
forall a. a -> [a] -> [a]
: [TargetDetails]
all_targets', NormalizedFilePath
-> (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
-> HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert NormalizedFilePath
_cfp (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
flags_map', (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags)
where all_targets' :: [TargetDetails]
all_targets' = [[TargetDetails]] -> [TargetDetails]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TargetDetails]]
all_target_details
flags_map' :: HashMap
NormalizedFilePath
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
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')
this_target_details :: TargetDetails
this_target_details = Target
-> ([FileDiagnostic], Maybe HscEnvEq)
-> DependencyInfo
-> [NormalizedFilePath]
-> TargetDetails
TargetDetails (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
_cfp) ([FileDiagnostic], Maybe HscEnvEq)
this_error_env DependencyInfo
this_dep_info [NormalizedFilePath
_cfp]
this_flags :: (([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
this_flags = (([FileDiagnostic], Maybe HscEnvEq)
this_error_env, DependencyInfo
this_dep_info)
this_error_env :: ([FileDiagnostic], Maybe HscEnvEq)
this_error_env = ([FileDiagnostic
this_error], Maybe HscEnvEq
forall a. Maybe a
Nothing)
this_error :: FileDiagnostic
this_error = 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) NormalizedFilePath
_cfp
(Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ Text
"No cradle target found. Is this file listed in the targets of your cradle?"
, Text
"If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
]
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,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> (NormalizedFilePath, Maybe String))
-> [(NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [(NormalizedFilePath, Maybe String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,Maybe String
hieYaml) (NormalizedFilePath -> (NormalizedFilePath, Maybe String))
-> ((NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> NormalizedFilePath)
-> (NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> (NormalizedFilePath, Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))
-> NormalizedFilePath
forall a b. (a, b) -> a
fst) ([(NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [(NormalizedFilePath, Maybe String)])
-> [(NormalizedFilePath,
(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo))]
-> [(NormalizedFilePath, Maybe String)]
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))
Key
keys2 <- IO Key
invalidateShakeCache
VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
restartShakeSession VFSModified
VFSUnmodified String
"new component" [] (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Key
keys1 <- [TargetDetails] -> IO Key
extendKnownTargets [TargetDetails]
all_targets
[Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Key
keys1, Key
keys2]
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
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' <>)
(([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)
this_options
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
let lfpLog :: String
lfpLog = String -> ShowS
makeRelative String
rootDir String
cfp
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
rootDir
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)
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
lfpLog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
Either [CradleError] (ComponentOptions, String, String)
eopts <- Maybe (LanguageContextEnv Config)
-> (LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
-> LspT
Config
IO
(Either [CradleError] (ComponentOptions, String, String)))
-> IO (Either [CradleError] (ComponentOptions, String, String))
-> IO (Either [CradleError] (ComponentOptions, String, 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 (\LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
act -> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> LspT Config IO ())
-> LspT
Config
IO
(Either [CradleError] (ComponentOptions, String, String)))
-> LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
progMsg Maybe ProgressToken
forall a. Maybe a
Nothing ProgressCancellable
NotCancellable (LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
-> (Text -> LspT Config IO ())
-> LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
forall a b. a -> b -> a
const LspT
Config IO (Either [CradleError] (ComponentOptions, String, String))
act)) (IO (Either [CradleError] (ComponentOptions, String, String))
-> IO (Either [CradleError] (ComponentOptions, String, String)))
-> IO (Either [CradleError] (ComponentOptions, String, String))
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a b. (a -> b) -> a -> b
$
String
-> ((String -> String -> IO ())
-> IO (Either [CradleError] (ComponentOptions, String, String)))
-> IO (Either [CradleError] (ComponentOptions, String, 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, String)))
-> IO (Either [CradleError] (ComponentOptions, String, String)))
-> ((String -> String -> IO ())
-> IO (Either [CradleError] (ComponentOptions, String, String)))
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a b. (a -> b) -> a -> b
$ \String -> String -> IO ()
addTag -> do
String -> String -> IO ()
addTag String
"file" String
lfpLog
[String]
old_files <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
cradle_files
Either [CradleError] (ComponentOptions, String, String)
res <- Recorder (WithPriority Log)
-> SessionLoadingPreferenceConfig
-> Cradle Void
-> String
-> [String]
-> IO (Either [CradleError] (ComponentOptions, String, String))
cradleToOptsAndLibDir Recorder (WithPriority Log)
recorder (Config -> SessionLoadingPreferenceConfig
sessionLoading Config
clientConfig) Cradle Void
cradle String
cfp [String]
old_files
String -> String -> IO ()
addTag String
"result" (Either [CradleError] (ComponentOptions, String, String) -> String
forall a. Show a => a -> String
show Either [CradleError] (ComponentOptions, String, String)
res)
Either [CradleError] (ComponentOptions, String, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either [CradleError] (ComponentOptions, String, 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, String) -> Log
LogSessionLoadingResult Either [CradleError] (ComponentOptions, String, String)
eopts
case Either [CradleError] (ComponentOptions, String, String)
eopts of
Right (ComponentOptions
opts, String
libDir, String
version) -> do
let compileTime :: Version
compileTime = Version
fullCompilerVersion
case [(Version, String)] -> [(Version, String)]
forall a. [a] -> [a]
reverse ([(Version, String)] -> [(Version, String)])
-> [(Version, String)] -> [(Version, String)]
forall a b. (a -> b) -> a -> b
$ ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion String
version of
[] -> 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 version could not be parsed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
version
((Version
runTime, String
_):[(Version, String)]
_)
| Version
compileTime Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
runTime -> 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)
| Bool
otherwise -> (([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),[])
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)
let
didSessionLoadingPreferenceConfigChange :: IO Bool
didSessionLoadingPreferenceConfigChange :: IO Bool
didSessionLoadingPreferenceConfigChange = do
Maybe SessionLoadingPreferenceConfig
mLoadingConfig <- Var (Maybe SessionLoadingPreferenceConfig)
-> IO (Maybe SessionLoadingPreferenceConfig)
forall a. Var a -> IO a
readVar Var (Maybe SessionLoadingPreferenceConfig)
biosSessionLoadingVar
case Maybe SessionLoadingPreferenceConfig
mLoadingConfig of
Maybe SessionLoadingPreferenceConfig
Nothing -> do
Var (Maybe SessionLoadingPreferenceConfig)
-> Maybe SessionLoadingPreferenceConfig -> IO ()
forall a. Var a -> a -> IO ()
writeVar Var (Maybe SessionLoadingPreferenceConfig)
biosSessionLoadingVar (SessionLoadingPreferenceConfig
-> Maybe SessionLoadingPreferenceConfig
forall a. a -> Maybe a
Just (Config -> SessionLoadingPreferenceConfig
sessionLoading Config
clientConfig))
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Just SessionLoadingPreferenceConfig
loadingConfig -> do
Var (Maybe SessionLoadingPreferenceConfig)
-> Maybe SessionLoadingPreferenceConfig -> IO ()
forall a. Var a -> a -> IO ()
writeVar Var (Maybe SessionLoadingPreferenceConfig)
biosSessionLoadingVar (SessionLoadingPreferenceConfig
-> Maybe SessionLoadingPreferenceConfig
forall a. a -> Maybe a
Just (Config -> SessionLoadingPreferenceConfig
sessionLoading Config
clientConfig))
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionLoadingPreferenceConfig
loadingConfig SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= Config -> SessionLoadingPreferenceConfig
sessionLoading Config
clientConfig)
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
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
Extra.whenM IO Bool
didSessionLoadingPreferenceConfigChange (IO () -> IO ()) -> IO () -> IO ()
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
Info Log
LogSessionLoadingChanged
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))
Var FilesMap -> (FilesMap -> IO FilesMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FilesMap
filesMap (IO FilesMap -> FilesMap -> IO FilesMap
forall a b. a -> b -> a
const (FilesMap -> IO FilesMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilesMap
forall k v. HashMap k v
HM.empty))
Var HieMap -> (HieMap -> IO HieMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var HieMap
hscEnvs (IO HieMap -> HieMap -> IO HieMap
forall a b. a -> b -> a
const (HieMap -> IO HieMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HieMap
forall k a. Map k a
Map.empty))
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
let cfp :: String
cfp = ShowS
toAbsolutePath 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
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))
Var FilesMap -> (FilesMap -> IO FilesMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FilesMap
filesMap (IO FilesMap -> FilesMap -> IO FilesMap
forall a b. a -> b -> a
const (FilesMap -> IO FilesMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilesMap
forall k v. HashMap k v
HM.empty))
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] -> [RawComponentInfo] -> [RawComponentInfo]
forall a b. a -> b -> a
const []) 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
let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
getOptions :: String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
getOptions String
file = do
let ncfp :: NormalizedFilePath
ncfp = String -> NormalizedFilePath
toNormalizedFilePath' (ShowS
toAbsolutePath 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
TQueue (IO ())
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
-> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
forall result. TQueue (IO ()) -> IO result -> IO result
awaitRunInThread TQueue (IO ())
que (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
$ String -> IO (([FileDiagnostic], Maybe HscEnvEq), [String])
getOptions String
file
cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]
-> IO (Either [CradleError] (ComponentOptions, FilePath, String))
cradleToOptsAndLibDir :: Recorder (WithPriority Log)
-> SessionLoadingPreferenceConfig
-> Cradle Void
-> String
-> [String]
-> IO (Either [CradleError] (ComponentOptions, String, String))
cradleToOptsAndLibDir Recorder (WithPriority Log)
recorder SessionLoadingPreferenceConfig
loadConfig Cradle Void
cradle String
file [String]
old_fps = 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
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Cradle Void -> Log
LogCradle Cradle Void
cradle
CradleLoadResult ComponentOptions
cradleRes <- String
-> LoadStyle
-> Cradle Void
-> IO (CradleLoadResult ComponentOptions)
forall a.
String
-> LoadStyle -> Cradle a -> IO (CradleLoadResult ComponentOptions)
HieBios.getCompilerOptions String
file LoadStyle
loadStyle Cradle Void
cradle
case CradleLoadResult ComponentOptions
cradleRes of
CradleSuccess ComponentOptions
r -> do
CradleLoadResult String
libDirRes <- Cradle Void -> IO (CradleLoadResult String)
forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcLibDir Cradle Void
cradle
CradleLoadResult String
versionRes <- Cradle Void -> IO (CradleLoadResult String)
forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcVersion Cradle Void
cradle
case (String -> String -> (String, String))
-> CradleLoadResult String
-> CradleLoadResult String
-> CradleLoadResult (String, String)
forall a b c.
(a -> b -> c)
-> CradleLoadResult a -> CradleLoadResult b -> CradleLoadResult c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) CradleLoadResult String
libDirRes CradleLoadResult String
versionRes of
(CradleSuccess (String
libDir, String
version)) -> Either [CradleError] (ComponentOptions, String, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ComponentOptions, String, String)
-> Either [CradleError] (ComponentOptions, String, String)
forall a b. b -> Either a b
Right (ComponentOptions
r, String
libDir, String
version))
CradleFail CradleError
err -> Either [CradleError] (ComponentOptions, String, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError]
-> Either [CradleError] (ComponentOptions, String, String)
forall a b. a -> Either a b
Left [CradleError
err])
CradleLoadResult (String, 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, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError]
-> Either [CradleError] (ComponentOptions, String, String)
forall a b. a -> Either a b
Left [])
CradleFail CradleError
err -> Either [CradleError] (ComponentOptions, String, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError]
-> Either [CradleError] (ComponentOptions, String, 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, String)
-> IO (Either [CradleError] (ComponentOptions, String, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError]
-> Either [CradleError] (ComponentOptions, String, String)
forall a b. a -> Either a b
Left [])
where
loadStyle :: LoadStyle
loadStyle = case SessionLoadingPreferenceConfig
loadConfig of
SessionLoadingPreferenceConfig
PreferSingleComponentLoading -> LoadStyle
LoadFile
SessionLoadingPreferenceConfig
PreferMultiComponentLoading -> [String] -> LoadStyle
LoadWithContext [String]
old_fps
#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
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
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]
-> [String]
-> TargetId
-> IdeResult HscEnvEq
-> DependencyInfo
-> IO [TargetDetails]
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"]
]
let locs :: [NormalizedFilePath]
locs = (String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> NormalizedFilePath
toNormalizedFilePath' [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]
fromTargetId [String]
_ [String]
_ (GHC.TargetFile String
f Maybe Phase
_) ([FileDiagnostic], Maybe HscEnvEq)
env DependencyInfo
deps = do
let nf :: NormalizedFilePath
nf = String -> NormalizedFilePath
toNormalizedFilePath' 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 }
#if MIN_VERSION_ghc(9,3,0)
checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages]
checkHomeUnitsClosed' :: UnitEnv -> Set UnitId -> [DriverMessages]
checkHomeUnitsClosed' UnitEnv
ue Set UnitId
home_id_set
| Set UnitId -> Bool
forall a. Set a -> Bool
OS.null Set UnitId
bad_unit_ids = []
| Bool
otherwise = [MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
GHC.mkPlainErrorMsgEnvelope SrcSpan
rootLoc (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (Set UnitId -> [UnitId]
forall a. Set a -> [a]
OS.toList Set UnitId
bad_unit_ids)]
where
bad_unit_ids :: Set UnitId
bad_unit_ids = Set UnitId
upwards_closure Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
OS.\\ Set UnitId
home_id_set
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
Compat.fsLit String
"<command line>")
graph :: Graph (Node UnitId UnitId)
graph :: Graph (Node UnitId UnitId)
graph = [Node UnitId UnitId] -> Graph (Node UnitId UnitId)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node UnitId UnitId]
graphNodes
downwards_closure :: Graph (Node UnitId UnitId)
downwards_closure
= [Node UnitId UnitId] -> Graph (Node UnitId UnitId)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [ UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (Set UnitId -> [UnitId]
forall a. Set a -> [a]
OS.toList Set UnitId
deps)
| (UnitId
uid, Set UnitId
deps) <- Map UnitId (Set UnitId) -> [(UnitId, Set UnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList (Graph (Node UnitId UnitId)
-> (Node UnitId UnitId -> UnitId) -> Map UnitId (Set UnitId)
forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph (Node UnitId UnitId)
graph Node UnitId UnitId -> UnitId
forall key payload. Node key payload -> key
node_key)]
inverse_closure :: Graph (Node UnitId UnitId)
inverse_closure = Graph (Node UnitId UnitId) -> Graph (Node UnitId UnitId)
forall node. Graph node -> Graph node
transposeG Graph (Node UnitId UnitId)
downwards_closure
upwards_closure :: Set UnitId
upwards_closure = [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
$ (Node UnitId UnitId -> UnitId) -> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Node UnitId UnitId -> UnitId
forall key payload. Node key payload -> key
node_key ([Node UnitId UnitId] -> [UnitId])
-> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ Graph (Node UnitId UnitId)
-> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall node. Graph node -> [node] -> [node]
reachablesG Graph (Node UnitId UnitId)
inverse_closure [UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid [] | UnitId
uid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
OS.toList Set UnitId
home_id_set]
all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId)
all_unit_direct_deps :: UniqMap UnitId (Set UnitId)
all_unit_direct_deps
= (UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UniqMap UnitId (Set UnitId)
-> UnitEnvGraph HomeUnitEnv
-> UniqMap UnitId (Set UnitId)
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
forall k a. UniqMap k a
emptyUniqMap (UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId)
forall a b. (a -> b) -> a -> b
$ UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
ue
where
go :: UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
rest UnitId
this HomeUnitEnv
this_uis =
(Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
forall a k.
(a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
plusUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
OS.union
((Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UnitId
-> Set UnitId
-> UniqMap UnitId (Set UnitId)
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
OS.union UniqMap UnitId (Set UnitId)
external_depends UnitId
this ([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]
this_deps))
UniqMap UnitId (Set UnitId)
rest
where
external_depends :: UniqMap UnitId (Set UnitId)
external_depends = (GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> Set UnitId)
-> UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> UniqMap UnitId (Set UnitId)
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
OS.fromList ([UnitId] -> Set UnitId)
-> (GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> [UnitId])
-> GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends)
#if !MIN_VERSION_ghc(9,7,0)
(UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> UniqMap UnitId (Set UnitId))
-> UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> UniqMap UnitId (Set UnitId)
forall a b. (a -> b) -> a -> b
$ [(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))]
-> UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))]
-> UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))))
-> [(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))]
-> UniqMap
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
forall a b. (a -> b) -> a -> b
$ Map
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> [(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))]
forall k a. Map k a -> [(k, a)]
Map.toList
#endif
(Map
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> [(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))])
-> Map
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
-> [(UnitId,
GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))]
forall a b. (a -> b) -> a -> b
$ UnitState
-> Map
UnitId
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId)))
unitInfoMap UnitState
this_units
this_units :: UnitState
this_units = HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
this_uis
this_deps :: [UnitId]
this_deps = [ GenUnit UnitId -> UnitId
Compat.toUnitId GenUnit UnitId
unit | (GenUnit UnitId
unit,Just PackageArg
_) <- UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
this_units]
graphNodes :: [Node UnitId UnitId]
graphNodes :: [Node UnitId UnitId]
graphNodes = Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
forall a. Set a
OS.empty Set UnitId
home_id_set
where
go :: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo
= case Set UnitId -> Maybe (UnitId, Set UnitId)
forall a. Set a -> Maybe (a, Set a)
OS.minView Set UnitId
todo of
Maybe (UnitId, Set UnitId)
Nothing -> []
Just (UnitId
uid, Set UnitId
todo')
| UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
OS.member UnitId
uid Set UnitId
done -> Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo'
| Bool
otherwise -> case UniqMap UnitId (Set UnitId) -> UnitId -> Maybe (Set UnitId)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId (Set UnitId)
all_unit_direct_deps UnitId
uid of
Maybe (Set UnitId)
Nothing -> String -> SDoc -> [Node UnitId UnitId]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"uid not found" ((UnitId, UniqMap UnitId (Set UnitId)) -> SDoc
forall a. Outputable a => a -> SDoc
Compat.ppr (UnitId
uid, UniqMap UnitId (Set UnitId)
all_unit_direct_deps))
Just Set UnitId
depends ->
let todo'' :: Set UnitId
todo'' = (Set UnitId
depends Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
OS.\\ Set UnitId
done) Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`OS.union` Set UnitId
todo'
in UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (Set UnitId -> [UnitId]
forall a. Set a -> [a]
OS.toList Set UnitId
depends) Node UnitId UnitId -> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall a. a -> [a] -> [a]
: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go (UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
OS.insert UnitId
uid Set UnitId
done) Set UnitId
todo''
#endif
newComponentCache
:: Recorder (WithPriority Log)
-> [String]
-> Maybe FilePath
-> NormalizedFilePath
-> HscEnv
-> [ComponentInfo]
-> [ComponentInfo]
-> FilePath
-> IO [ [TargetDetails] ]
newComponentCache :: Recorder (WithPriority Log)
-> [String]
-> Maybe String
-> NormalizedFilePath
-> HscEnv
-> [ComponentInfo]
-> [ComponentInfo]
-> String
-> IO [[TargetDetails]]
newComponentCache Recorder (WithPriority Log)
recorder [String]
exts Maybe String
cradlePath NormalizedFilePath
_cfp HscEnv
hsc_env [ComponentInfo]
old_cis [ComponentInfo]
new_cis String
dir = 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)
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' <-
[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 -> [DriverMessages]
checkHomeUnitsClosed' (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hscEnv') (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hscEnv')
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
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]) -> IO [[TargetDetails]]
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]) -> IO [[TargetDetails]])
-> (ComponentInfo -> IO [TargetDetails]) -> IO [[TargetDetails]]
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 -> String -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq String
dir) Maybe String
cradlePath
HscEnv
thisEnv <- do
#if MIN_VERSION_ghc(9,3,0)
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
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
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)
targetEnv, DependencyInfo
targetDepends)
() -> 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] -> IO [TargetDetails]
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)
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
type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]
type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath)
data RawComponentInfo = RawComponentInfo
{ RawComponentInfo -> UnitId
rawComponentUnitId :: UnitId
, RawComponentInfo -> DynFlags
rawComponentDynFlags :: DynFlags
, RawComponentInfo -> [Target]
rawComponentTargets :: [GHC.Target]
, RawComponentInfo -> NormalizedFilePath
rawComponentFP :: NormalizedFilePath
, RawComponentInfo -> ComponentOptions
rawComponentCOptions :: ComponentOptions
, RawComponentInfo -> DependencyInfo
rawComponentDependencyInfo :: DependencyInfo
}
data ComponentInfo = ComponentInfo
{ ComponentInfo -> UnitId
componentUnitId :: UnitId
, ComponentInfo -> DynFlags
componentDynFlags :: DynFlags
, ComponentInfo -> [UnitId]
componentInternalUnits :: [UnitId]
, ComponentInfo -> [Target]
componentTargets :: [GHC.Target]
, ComponentInfo -> NormalizedFilePath
componentFP :: NormalizedFilePath
, ComponentInfo -> ComponentOptions
componentCOptions :: ComponentOptions
, ComponentInfo -> DependencyInfo
componentDependencyInfo :: DependencyInfo
}
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)
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)
_removeInplacePackages
:: UnitId
-> [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)
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)
setOptions :: GhcMonad m
=> NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> FilePath
-> m (NonEmpty (DynFlags, [GHC.Target]))
setOptions :: forall (m :: * -> *).
GhcMonad m =>
NormalizedFilePath
-> ComponentOptions
-> DynFlags
-> String
-> m (NonEmpty (DynFlags, [Target]))
setOptions NormalizedFilePath
cfp (ComponentOptions [String]
theOpts String
compRoot [String]
_) DynFlags
dflags String
rootDir = 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')
let abs_fp :: String
abs_fp = String -> ShowS
toAbsolute String
rootDir (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
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 = GenUnit UnitId -> UnitId
Compat.toUnitId (String -> GenUnit UnitId
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
$
(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
$
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
DynFlags
dflags''
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 =
DynFlags
d { hiDir = Just f}
setODir :: FilePath -> DynFlags -> DynFlags
setODir :: String -> DynFlags -> DynFlags
setODir String
f DynFlags
d =
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
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)
cacheDir :: String
cacheDir :: String
cacheDir = String
"ghcide"
data PackageSetupException
= PackageSetupException
{ PackageSetupException -> String
message :: !String
}
| GhcVersionMismatch
{ PackageSetupException -> Version
compileTime :: !Version
, PackageSetupException -> Version
runTime :: !Version
}
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
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
fullCompilerVersion
, 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."]
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)