{-# LANGUAGE TypeFamilies #-}

{-|
The logic for setting up a ghcide session by tapping into hie-bios.
-}
module Development.IDE.Session (loadSession) where

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

import Control.Concurrent.Async
import Control.Concurrent.Extra
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Extra
import Control.Monad.IO.Class
import qualified Crypto.Hash.SHA1 as H
import qualified Data.ByteString.Char8 as B
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString.Base16 as B16
import Data.Either.Extra
import Data.Function
import Data.Hashable
import Data.List
import Data.IORef
import Data.Maybe
import Data.Time.Clock
import Data.Version
import Development.IDE.Core.OfInterest
import Development.IDE.Core.Shake
import Development.IDE.Core.RuleTypes
import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)
import qualified Development.IDE.GHC.Compat as GHC
import Development.IDE.GHC.Util
import Development.IDE.Session.VersionCheck
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Exports
import Development.IDE.Types.Location
import Development.IDE.Types.Logger
import Development.IDE.Types.Options
import Development.Shake (Action)
import GHC.Check
import HIE.Bios
import HIE.Bios.Environment hiding (getCacheDir)
import HIE.Bios.Types
import Hie.Implicit.Cradle (loadImplicitHieCradle)
import Language.Haskell.LSP.Core
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import System.Directory
import qualified System.Directory.Extra as IO
import System.FilePath
import System.Info
import System.IO

import GHCi
import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC)
import Linker
import Module
import NameCache
import Packages
import Control.Exception (evaluate)

-- | Given a root directory, return a Shake 'Action' which setups an
-- 'IdeGhcSession' given a file.
-- Some of the many things this does:
--
-- * Find the cradle for the file
-- * Get the session options,
-- * Get the GHC lib directory
-- * Make sure the GHC compiletime and runtime versions match
-- * Restart the Shake session
--
-- This is the key function which implements multi-component support. All
-- components mapping to the same hie.yaml file are mapped to the same
-- HscEnv which is updated as new components are discovered.
loadSession :: FilePath -> IO (Action IdeGhcSession)
loadSession :: FilePath -> IO (Action IdeGhcSession)
loadSession FilePath
dir = do
  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
  Var HieMap
hscEnvs <- HieMap -> IO (Var HieMap)
forall a. a -> IO (Var a)
newVar HieMap
forall k a. Map k a
Map.empty :: IO (Var HieMap)
  -- Mapping from a Filepath to HscEnv
  Var FlagsMap
fileToFlags <- FlagsMap -> IO (Var FlagsMap)
forall a. a -> IO (Var a)
newVar FlagsMap
forall k a. Map k a
Map.empty :: IO (Var FlagsMap)
  -- Version of the mappings above
  Var Int
version <- Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar Int
0
  let returnWithVersion :: (FilePath -> IO (IdeResult HscEnvEq, [FilePath]))
-> Action IdeGhcSession
returnWithVersion FilePath -> IO (IdeResult HscEnvEq, [FilePath])
fun = (FilePath -> IO (IdeResult HscEnvEq, [FilePath]))
-> Int -> IdeGhcSession
IdeGhcSession FilePath -> IO (IdeResult HscEnvEq, [FilePath])
fun (Int -> IdeGhcSession) -> Action Int -> Action IdeGhcSession
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> Action Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Var Int -> IO Int
forall a. Var a -> IO a
readVar Var Int
version)
  let invalidateShakeCache :: IO ()
invalidateShakeCache = do
        Var Int -> (Int -> IO Int) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var Int
version (Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Int -> Int) -> Int -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
succ)
  -- This caches the mapping from Mod.hs -> hie.yaml
  FilePath -> IO (Maybe FilePath)
cradleLoc <- IO (FilePath -> IO (Maybe FilePath))
-> IO (FilePath -> IO (Maybe FilePath))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath -> IO (Maybe FilePath))
 -> IO (FilePath -> IO (Maybe FilePath)))
-> IO (FilePath -> IO (Maybe FilePath))
-> IO (FilePath -> IO (Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO (Maybe FilePath))
-> IO (FilePath -> IO (Maybe FilePath))
forall a b. Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO ((FilePath -> IO (Maybe FilePath))
 -> IO (FilePath -> IO (Maybe FilePath)))
-> (FilePath -> IO (Maybe FilePath))
-> IO (FilePath -> IO (Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ \FilePath
v -> do
      Maybe FilePath
res <- FilePath -> IO (Maybe FilePath)
findCradle FilePath
v
      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
      -- try and normalise that
      -- e.g. see https://github.com/digital-asset/ghcide/issues/126
      Maybe FilePath
res' <- (FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO FilePath
makeAbsolute Maybe FilePath
res
      Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
res'

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

  Action IdeGhcSession -> IO (Action IdeGhcSession)
forall (m :: * -> *) a. Monad m => a -> m a
return (Action IdeGhcSession -> IO (Action IdeGhcSession))
-> Action IdeGhcSession -> IO (Action IdeGhcSession)
forall a b. (a -> b) -> a -> b
$ do
    extras :: ShakeExtras
extras@ShakeExtras{Logger
logger :: ShakeExtras -> Logger
logger :: Logger
logger, FromServerMessage -> IO ()
eventer :: ShakeExtras -> FromServerMessage -> IO ()
eventer :: FromServerMessage -> IO ()
eventer, [DelayedAction ()] -> IO ()
restartShakeSession :: ShakeExtras -> [DelayedAction ()] -> IO ()
restartShakeSession :: [DelayedAction ()] -> IO ()
restartShakeSession,
                       WithIndefiniteProgressFunc
withIndefiniteProgress :: ShakeExtras -> WithIndefiniteProgressFunc
withIndefiniteProgress :: WithIndefiniteProgressFunc
withIndefiniteProgress, IORef NameCache
ideNc :: ShakeExtras -> IORef NameCache
ideNc :: IORef NameCache
ideNc, Var (Hashed KnownTargets)
knownTargetsVar :: ShakeExtras -> Var (Hashed KnownTargets)
knownTargetsVar :: Var (Hashed KnownTargets)
knownTargetsVar
                      } <- Action ShakeExtras
getShakeExtras

    IdeOptions{ optTesting :: IdeOptions -> IdeTesting
optTesting = IdeTesting Bool
optTesting
              , optCheckProject :: IdeOptions -> CheckProject
optCheckProject = CheckProject Bool
checkProject
              , DynFlags -> DynFlags
optCustomDynFlags :: IdeOptions -> DynFlags -> DynFlags
optCustomDynFlags :: DynFlags -> DynFlags
optCustomDynFlags
              , [FilePath]
optExtensions :: IdeOptions -> [FilePath]
optExtensions :: [FilePath]
optExtensions
              } <- Action IdeOptions
getIdeOptions

        -- populate the knownTargetsVar with all the
        -- files in the project so that `knownFiles` can learn about them and
        -- we can generate a complete module graph
    let extendKnownTargets :: [TargetDetails] -> IO ()
extendKnownTargets [TargetDetails]
newTargets = do
          [(Target, [NormalizedFilePath])]
knownTargets <- [TargetDetails]
-> (TargetDetails -> IO (Target, [NormalizedFilePath]))
-> IO [(Target, [NormalizedFilePath])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TargetDetails]
newTargets ((TargetDetails -> IO (Target, [NormalizedFilePath]))
 -> IO [(Target, [NormalizedFilePath])])
-> (TargetDetails -> IO (Target, [NormalizedFilePath]))
-> IO [(Target, [NormalizedFilePath])]
forall a b. (a -> b) -> a -> b
$ \TargetDetails{[NormalizedFilePath]
IdeResult HscEnvEq
DependencyInfo
Target
targetLocations :: TargetDetails -> [NormalizedFilePath]
targetDepends :: TargetDetails -> DependencyInfo
targetEnv :: TargetDetails -> IdeResult HscEnvEq
targetTarget :: TargetDetails -> Target
targetLocations :: [NormalizedFilePath]
targetDepends :: DependencyInfo
targetEnv :: IdeResult HscEnvEq
targetTarget :: Target
..} ->
            case Target
targetTarget of
              TargetFile NormalizedFilePath
f -> (Target, [NormalizedFilePath]) -> IO (Target, [NormalizedFilePath])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Target
targetTarget, [NormalizedFilePath
f])
              TargetModule ModuleName
_ -> do
                [NormalizedFilePath]
found <- (NormalizedFilePath -> IO Bool)
-> [NormalizedFilePath] -> IO [NormalizedFilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
IO.doesFileExist (FilePath -> IO Bool)
-> (NormalizedFilePath -> FilePath)
-> NormalizedFilePath
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> FilePath
fromNormalizedFilePath) [NormalizedFilePath]
targetLocations
                (Target, [NormalizedFilePath]) -> IO (Target, [NormalizedFilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (Target
targetTarget, [NormalizedFilePath]
found)
          Var (Hashed KnownTargets)
-> (Hashed KnownTargets -> IO (Hashed KnownTargets)) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (Hashed KnownTargets)
knownTargetsVar ((Hashed KnownTargets -> IO (Hashed KnownTargets)) -> IO ())
-> (Hashed KnownTargets -> IO (Hashed KnownTargets)) -> IO ()
forall a b. (a -> b) -> a -> b
$ (KnownTargets -> IO KnownTargets)
-> Hashed KnownTargets -> IO (Hashed KnownTargets)
forall b (f :: * -> *) a.
(Hashable b, Functor f) =>
(a -> f b) -> Hashed a -> f (Hashed b)
traverseHashed ((KnownTargets -> IO KnownTargets)
 -> Hashed KnownTargets -> IO (Hashed KnownTargets))
-> (KnownTargets -> IO KnownTargets)
-> Hashed KnownTargets
-> IO (Hashed KnownTargets)
forall a b. (a -> b) -> a -> b
$ \KnownTargets
known -> do
            let known' :: KnownTargets
known' = ([NormalizedFilePath]
 -> [NormalizedFilePath] -> [NormalizedFilePath])
-> KnownTargets -> KnownTargets -> KnownTargets
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith [NormalizedFilePath]
-> [NormalizedFilePath] -> [NormalizedFilePath]
forall a. Semigroup a => a -> a -> a
(<>) KnownTargets
known (KnownTargets -> KnownTargets) -> KnownTargets -> KnownTargets
forall a b. (a -> b) -> a -> b
$ [(Target, [NormalizedFilePath])] -> KnownTargets
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Target, [NormalizedFilePath])]
knownTargets
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KnownTargets
known KnownTargets -> KnownTargets -> Bool
forall a. Eq a => a -> a -> Bool
/= KnownTargets
known') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Known files updated: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    FilePath -> Text
T.pack(HashMap Target [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show (HashMap Target [FilePath] -> FilePath)
-> HashMap Target [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (([NormalizedFilePath] -> [FilePath])
-> KnownTargets -> HashMap Target [FilePath]
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map (([NormalizedFilePath] -> [FilePath])
 -> KnownTargets -> HashMap Target [FilePath])
-> ((NormalizedFilePath -> FilePath)
    -> [NormalizedFilePath] -> [FilePath])
-> (NormalizedFilePath -> FilePath)
-> KnownTargets
-> HashMap Target [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormalizedFilePath -> FilePath)
-> [NormalizedFilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map) NormalizedFilePath -> FilePath
fromNormalizedFilePath KnownTargets
known')
            KnownTargets -> IO KnownTargets
forall a. a -> IO a
evaluate KnownTargets
known'

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

              [ComponentInfo]
new_deps' <- [RawComponentInfo]
-> (RawComponentInfo -> IO ComponentInfo) -> IO [ComponentInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawComponentInfo]
new_deps ((RawComponentInfo -> IO ComponentInfo) -> IO [ComponentInfo])
-> (RawComponentInfo -> IO ComponentInfo) -> IO [ComponentInfo]
forall a b. (a -> b) -> a -> b
$ \RawComponentInfo{[Target]
DependencyInfo
InstalledUnitId
DynFlags
NormalizedFilePath
ComponentOptions
rawComponentDependencyInfo :: RawComponentInfo -> DependencyInfo
rawComponentCOptions :: RawComponentInfo -> ComponentOptions
rawComponentFP :: RawComponentInfo -> NormalizedFilePath
rawComponentTargets :: RawComponentInfo -> [Target]
rawComponentDynFlags :: RawComponentInfo -> DynFlags
rawComponentDependencyInfo :: DependencyInfo
rawComponentCOptions :: ComponentOptions
rawComponentFP :: NormalizedFilePath
rawComponentTargets :: [Target]
rawComponentDynFlags :: DynFlags
rawComponentUnitId :: InstalledUnitId
rawComponentUnitId :: RawComponentInfo -> InstalledUnitId
..} -> do
                  -- Remove all inplace dependencies from package flags for
                  -- components in this HscEnv
                  let (DynFlags
df2, [InstalledUnitId]
uids) = [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
removeInplacePackages [InstalledUnitId]
inplace DynFlags
rawComponentDynFlags
                  let prefix :: FilePath
prefix = InstalledUnitId -> FilePath
forall a. Show a => a -> FilePath
show InstalledUnitId
rawComponentUnitId
                  -- See Note [Avoiding bad interface files]
                  DynFlags
processed_df <- Logger
-> FilePath
-> [FilePath]
-> ComponentOptions
-> DynFlags
-> IO DynFlags
forall (m :: * -> *).
MonadIO m =>
Logger
-> FilePath
-> [FilePath]
-> ComponentOptions
-> DynFlags
-> m DynFlags
setCacheDir Logger
logger FilePath
prefix ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (InstalledUnitId -> FilePath) -> [InstalledUnitId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> FilePath
forall a. Show a => a -> FilePath
show [InstalledUnitId]
uids) ComponentOptions
opts DynFlags
df2
                  -- The final component information, mostly the same but the DynFlags don't
                  -- contain any packages which are also loaded
                  -- into the same component.
                  ComponentInfo -> IO ComponentInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComponentInfo -> IO ComponentInfo)
-> ComponentInfo -> IO ComponentInfo
forall a b. (a -> b) -> a -> b
$ InstalledUnitId
-> DynFlags
-> [InstalledUnitId]
-> [Target]
-> NormalizedFilePath
-> ComponentOptions
-> DependencyInfo
-> ComponentInfo
ComponentInfo InstalledUnitId
rawComponentUnitId
                                       DynFlags
processed_df
                                       [InstalledUnitId]
uids
                                       [Target]
rawComponentTargets
                                       NormalizedFilePath
rawComponentFP
                                       ComponentOptions
rawComponentCOptions
                                       DependencyInfo
rawComponentDependencyInfo
              -- Make a new HscEnv, we have to recompile everything from
              -- scratch again (for now)
              -- It's important to keep the same NameCache though for reasons
              -- that I do not fully understand
              Logger -> Text -> IO ()
logInfo Logger
logger (FilePath -> Text
T.pack (FilePath
"Making new HscEnv" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [InstalledUnitId] -> FilePath
forall a. Show a => a -> FilePath
show [InstalledUnitId]
inplace))
              HscEnv
hscEnv <- IORef NameCache -> FilePath -> IO HscEnv
emptyHscEnv IORef NameCache
ideNc FilePath
libDir
              HscEnv
newHscEnv <-
                -- Add the options for the current component to the HscEnv
                HscEnv -> Ghc HscEnv -> IO HscEnv
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
hscEnv (Ghc HscEnv -> IO HscEnv) -> Ghc HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ do
                  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df
                  Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

              -- Modify the map so the hieYaml now maps to the newly created
              -- HscEnv
              -- Returns
              -- . the new HscEnv so it can be used to modify the
              --   FilePath -> HscEnv map (fileToFlags)
              -- . The information for the new component which caused this cache miss
              -- . The modified information (without -inplace flags) for
              --   existing packages
              (HieMap, (HscEnv, ComponentInfo, [ComponentInfo]))
-> IO (HieMap, (HscEnv, ComponentInfo, [ComponentInfo]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> (HscEnv, [RawComponentInfo]) -> HieMap -> HieMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Maybe FilePath
hieYaml (HscEnv
newHscEnv, [RawComponentInfo]
new_deps) HieMap
m, (HscEnv
newHscEnv, [ComponentInfo] -> ComponentInfo
forall a. [a] -> a
head [ComponentInfo]
new_deps', [ComponentInfo] -> [ComponentInfo]
forall a. [a] -> [a]
tail [ComponentInfo]
new_deps'))


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

          -- Whenever we spin up a session on Linux, dynamically load libm.so.6
          -- in. We need this in case the binary is statically linked, in which
          -- case the interactive session will fail when trying to load
          -- ghc-prim, which happens whenever Template Haskell is being
          -- evaluated or haskell-language-server's eval plugin tries to run
          -- some code. If the binary is dynamically linked, then this will have
          -- no effect.
          -- See https://github.com/haskell/haskell-language-server/issues/221
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
os FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"linux") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            HscEnv -> IO ()
initObjLinker HscEnv
hscEnv
            Maybe FilePath
res <- HscEnv -> FilePath -> IO (Maybe FilePath)
loadDLL HscEnv
hscEnv FilePath
"libm.so.6"
            case Maybe FilePath
res of
              Maybe FilePath
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just FilePath
err -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                FilePath
"Error dynamically loading libm.so.6:\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err

          -- Make a map from unit-id to DynFlags, this is used when trying to
          -- resolve imports. (especially PackageImports)
          let uids :: [(InstalledUnitId, DynFlags)]
uids = (ComponentInfo -> (InstalledUnitId, DynFlags))
-> [ComponentInfo] -> [(InstalledUnitId, DynFlags)]
forall a b. (a -> b) -> [a] -> [b]
map (\ComponentInfo
ci -> (ComponentInfo -> InstalledUnitId
componentUnitId ComponentInfo
ci, ComponentInfo -> DynFlags
componentDynFlags ComponentInfo
ci)) (ComponentInfo
new ComponentInfo -> [ComponentInfo] -> [ComponentInfo]
forall a. a -> [a] -> [a]
: [ComponentInfo]
old_deps)

          -- For each component, now make a new HscEnvEq which contains the
          -- HscEnv for the hie.yaml file but the DynFlags for that component

          -- New HscEnv for the component in question, returns the new HscEnvEq and
          -- a mapping from FilePath to the newly created HscEnvEq.
          let new_cache :: ComponentInfo
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
new_cache = Logger
-> [FilePath]
-> Maybe FilePath
-> NormalizedFilePath
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> ComponentInfo
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
newComponentCache Logger
logger [FilePath]
optExtensions Maybe FilePath
hieYaml NormalizedFilePath
_cfp HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
uids
          ([TargetDetails]
cs, (IdeResult HscEnvEq, DependencyInfo)
res) <- ComponentInfo
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
new_cache ComponentInfo
new
          -- Modified cache targets for everything else in the hie.yaml file
          -- which now uses the same EPS and so on
          [TargetDetails]
cached_targets <- (ComponentInfo -> IO [TargetDetails])
-> [ComponentInfo] -> IO [TargetDetails]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
 -> [TargetDetails])
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-> IO [TargetDetails]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-> [TargetDetails]
forall a b. (a, b) -> a
fst (IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
 -> IO [TargetDetails])
-> (ComponentInfo
    -> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo)))
-> ComponentInfo
-> IO [TargetDetails]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentInfo
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
new_cache) [ComponentInfo]
old_deps

          let all_targets :: [TargetDetails]
all_targets = [TargetDetails]
cs [TargetDetails] -> [TargetDetails] -> [TargetDetails]
forall a. [a] -> [a] -> [a]
++ [TargetDetails]
cached_targets

          Var FlagsMap -> (FlagsMap -> IO FlagsMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FlagsMap
fileToFlags ((FlagsMap -> IO FlagsMap) -> IO ())
-> (FlagsMap -> IO FlagsMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FlagsMap
var -> do
              FlagsMap -> IO FlagsMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlagsMap -> IO FlagsMap) -> FlagsMap -> IO FlagsMap
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
-> FlagsMap
-> FlagsMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Maybe FilePath
hieYaml ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ((TargetDetails
 -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))])
-> [TargetDetails]
-> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TargetDetails
-> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
toFlagsMap [TargetDetails]
all_targets)) FlagsMap
var

          [TargetDetails] -> IO ()
extendKnownTargets [TargetDetails]
all_targets

          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
          IO ()
invalidateShakeCache
          [DelayedAction ()] -> IO ()
restartShakeSession [DelayedAction ()
kick]

          -- Typecheck all files in the project on startup
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TargetDetails] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TargetDetails]
cs 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 (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 (FilePath -> IO Bool
IO.doesFileExist (FilePath -> IO Bool)
-> (NormalizedFilePath -> FilePath)
-> NormalizedFilePath
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> FilePath
fromNormalizedFilePath) ((TargetDetails -> [NormalizedFilePath])
-> [TargetDetails] -> [NormalizedFilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TargetDetails -> [NormalizedFilePath]
targetLocations [TargetDetails]
cs)
                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
$ FilePath -> Priority -> Action () -> DelayedAction ()
forall a. FilePath -> Priority -> Action a -> DelayedAction a
mkDelayedAction FilePath
"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 k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [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 (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) [NormalizedFilePath]
cfps' [Maybe FileVersion]
mmt)
                    [Maybe HiFileResult]
modIfaces <- GetModIface -> [NormalizedFilePath] -> Action [Maybe HiFileResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetModIface
GetModIface [NormalizedFilePath]
cs_exist
                    -- update exports map
                    ShakeExtras
extras <- 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HiFileResult -> ModIface
hirModIface) [Maybe HiFileResult]
modIfaces
                    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Var ExportsMap -> (ExportsMap -> IO ExportsMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ (ShakeExtras -> Var ExportsMap
exportsMap ShakeExtras
extras) ((ExportsMap -> IO ExportsMap) -> IO ())
-> (ExportsMap -> IO ExportsMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ ExportsMap -> IO ExportsMap
forall a. a -> IO a
evaluate (ExportsMap -> IO ExportsMap)
-> (ExportsMap -> ExportsMap) -> ExportsMap -> IO ExportsMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExportsMap
exportsMap' ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<>)

          (IdeResult HscEnvEq, [FilePath])
-> IO (IdeResult HscEnvEq, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ((DependencyInfo -> [FilePath])
-> (IdeResult HscEnvEq, DependencyInfo)
-> (IdeResult HscEnvEq, [FilePath])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DependencyInfo -> [FilePath]
forall k a. Map k a -> [k]
Map.keys (IdeResult HscEnvEq, DependencyInfo)
res)

    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
        consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
consultCradle Maybe FilePath
hieYaml FilePath
cfp = do
           FilePath
lfp <- (FilePath -> FilePath -> FilePath)
-> FilePath -> FilePath -> FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> FilePath
makeRelative FilePath
cfp (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getCurrentDirectory
           Logger -> Text -> IO ()
logInfo Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath
"Consulting the cradle for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
lfp)

           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
hieYaml) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FromServerMessage
notifyUserImplicitCradle FilePath
lfp

           Cradle Void
cradle <- IO (Cradle Void)
-> (FilePath -> IO (Cradle Void))
-> Maybe FilePath
-> IO (Cradle Void)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO (Cradle Void)
forall a. FilePath -> IO (Cradle a)
loadImplicitHieCradle (FilePath -> IO (Cradle Void)) -> FilePath -> IO (Cradle Void)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
addTrailingPathSeparator FilePath
dir) FilePath -> IO (Cradle Void)
loadCradle Maybe FilePath
hieYaml

           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
optTesting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FromServerMessage
notifyCradleLoaded FilePath
lfp

           -- Display a user friendly progress message here: They probably don't know what a cradle is
           let progMsg :: Text
progMsg = Text
"Setting up " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (FilePath -> FilePath
takeBaseName (Cradle Void -> FilePath
forall a. Cradle a -> FilePath
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
<> FilePath -> Text
T.pack FilePath
lfp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
           Either [CradleError] (ComponentOptions, FilePath)
eopts <- Text
-> ProgressCancellable
-> IO (Either [CradleError] (ComponentOptions, FilePath))
-> IO (Either [CradleError] (ComponentOptions, FilePath))
WithIndefiniteProgressFunc
withIndefiniteProgress Text
progMsg ProgressCancellable
NotCancellable (IO (Either [CradleError] (ComponentOptions, FilePath))
 -> IO (Either [CradleError] (ComponentOptions, FilePath)))
-> IO (Either [CradleError] (ComponentOptions, FilePath))
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall a b. (a -> b) -> a -> b
$
             Cradle Void
-> FilePath
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall a.
Show a =>
Cradle a
-> FilePath
-> IO (Either [CradleError] (ComponentOptions, FilePath))
cradleToOptsAndLibDir Cradle Void
cradle FilePath
cfp

           Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath
"Session loading result: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Either [CradleError] (ComponentOptions, FilePath) -> FilePath
forall a. Show a => a -> FilePath
show Either [CradleError] (ComponentOptions, FilePath)
eopts)
           case Either [CradleError] (ComponentOptions, FilePath)
eopts of
             -- The cradle gave us some options so get to work turning them
             -- into and HscEnv.
             Right (ComponentOptions
opts, FilePath
libDir) -> do
               InstallationCheck
installationCheck <- GhcVersionChecker
ghcVersionChecker FilePath
libDir
               case InstallationCheck
installationCheck of
                 InstallationNotFound{FilePath
$sel:libdir:InstallationChecked :: InstallationCheck -> FilePath
libdir :: FilePath
..} ->
                     FilePath -> IO (IdeResult HscEnvEq, [FilePath])
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (IdeResult HscEnvEq, [FilePath]))
-> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath
"GHC installation not found in libdir: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
libdir
                 InstallationMismatch{FilePath
Version
$sel:compileTime:InstallationChecked :: InstallationCheck -> Version
$sel:runTime:InstallationChecked :: InstallationCheck -> Version
runTime :: Version
compileTime :: Version
libdir :: FilePath
$sel:libdir:InstallationChecked :: InstallationCheck -> FilePath
..} ->
                     (IdeResult HscEnvEq, [FilePath])
-> IO (IdeResult HscEnvEq, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (([FilePath
-> PackageSetupException
-> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderPackageSetupException FilePath
cfp GhcVersionMismatch :: Version -> Version -> PackageSetupException
GhcVersionMismatch{Version
runTime :: Version
compileTime :: Version
runTime :: Version
compileTime :: Version
..}], Maybe HscEnvEq
forall a. Maybe a
Nothing),[])
                 InstallationChecked Version
_compileTime Ghc PackageCheckResult
_ghcLibCheck ->
                   (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-> IO (IdeResult HscEnvEq, [FilePath])
session (Maybe FilePath
hieYaml, FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
cfp, ComponentOptions
opts, FilePath
libDir)
             -- Failure case, either a cradle error or the none cradle
             Left [CradleError]
err -> do
               DependencyInfo
dep_info <- [FilePath] -> IO DependencyInfo
getDependencyInfo (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
hieYaml)
               let ncfp :: NormalizedFilePath
ncfp = FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
cfp
               let res :: IdeResult HscEnvEq
res = ((CradleError -> (NormalizedFilePath, ShowDiagnostic, Diagnostic))
-> [CradleError]
-> [(NormalizedFilePath, ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
-> CradleError -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderCradleError NormalizedFilePath
ncfp) [CradleError]
err, Maybe HscEnvEq
forall a. Maybe a
Nothing)
               Var FlagsMap -> (FlagsMap -> IO FlagsMap) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var FlagsMap
fileToFlags ((FlagsMap -> IO FlagsMap) -> IO ())
-> (FlagsMap -> IO FlagsMap) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FlagsMap
var -> do
                 FlagsMap -> IO FlagsMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlagsMap -> IO FlagsMap) -> FlagsMap -> IO FlagsMap
forall a b. (a -> b) -> a -> b
$ (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
 -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
 -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
-> Maybe FilePath
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
-> FlagsMap
-> FlagsMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union Maybe FilePath
hieYaml (NormalizedFilePath
-> (IdeResult HscEnvEq, DependencyInfo)
-> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton NormalizedFilePath
ncfp (IdeResult HscEnvEq
res, DependencyInfo
dep_info)) FlagsMap
var
               (IdeResult HscEnvEq, [FilePath])
-> IO (IdeResult HscEnvEq, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (IdeResult HscEnvEq
res,[])

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

    -- The main function which gets options for a file. We only want one of these running
    -- at a time. Therefore the IORef contains the currently running cradle, if we try
    -- to get some more options then we wait for the currently running action to finish
    -- before attempting to do so.
    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
        getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
getOptions FilePath
file = do
            Maybe FilePath
hieYaml <- FilePath -> IO (Maybe FilePath)
cradleLoc FilePath
file
            (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
sessionOpts (Maybe FilePath
hieYaml, FilePath
file) IO (IdeResult HscEnvEq, [FilePath])
-> (PackageSetupException -> IO (IdeResult HscEnvEq, [FilePath]))
-> IO (IdeResult HscEnvEq, [FilePath])
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \PackageSetupException
e ->
                (IdeResult HscEnvEq, [FilePath])
-> IO (IdeResult HscEnvEq, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (([FilePath
-> PackageSetupException
-> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderPackageSetupException FilePath
file PackageSetupException
e], Maybe HscEnvEq
forall a. Maybe a
Nothing),[])

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

-- | Run the specific cradle on a specific FilePath via hie-bios.
-- This then builds dependencies or whatever based on the cradle, gets the
-- GHC options/dynflags needed for the session and the GHC library directory

cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
                      -> IO (Either [CradleError] (ComponentOptions, FilePath))
cradleToOptsAndLibDir :: Cradle a
-> FilePath
-> IO (Either [CradleError] (ComponentOptions, FilePath))
cradleToOptsAndLibDir Cradle a
cradle FilePath
file = do
    -- Start off by getting the session options
    let showLine :: FilePath -> IO ()
showLine FilePath
s = Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s)
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Output from setting up the cradle " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Cradle a -> FilePath
forall a. Show a => a -> FilePath
show Cradle a
cradle
    CradleLoadResult ComponentOptions
cradleRes <- CradleAction a
-> (FilePath -> IO ())
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> (FilePath -> IO ())
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
runCradle (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) FilePath -> IO ()
showLine FilePath
file
    case CradleLoadResult ComponentOptions
cradleRes of
        CradleSuccess ComponentOptions
r -> do
            -- Now get the GHC lib dir
            CradleLoadResult FilePath
libDirRes <- Cradle a -> IO (CradleLoadResult FilePath)
forall a. Cradle a -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir Cradle a
cradle
            case CradleLoadResult FilePath
libDirRes of
                -- This is the successful path
                CradleSuccess FilePath
libDir -> Either [CradleError] (ComponentOptions, FilePath)
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ComponentOptions, FilePath)
-> Either [CradleError] (ComponentOptions, FilePath)
forall a b. b -> Either a b
Right (ComponentOptions
r, FilePath
libDir))
                CradleFail CradleError
err -> Either [CradleError] (ComponentOptions, FilePath)
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, FilePath)
forall a b. a -> Either a b
Left [CradleError
err])
                -- For the None cradle perhaps we still want to report an Info
                -- message about the fact that the file is being ignored.
                CradleLoadResult FilePath
CradleNone -> Either [CradleError] (ComponentOptions, FilePath)
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, FilePath)
forall a b. a -> Either a b
Left [])

        CradleFail CradleError
err -> Either [CradleError] (ComponentOptions, FilePath)
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, FilePath)
forall a b. a -> Either a b
Left [CradleError
err])
        -- Same here
        CradleLoadResult ComponentOptions
CradleNone -> Either [CradleError] (ComponentOptions, FilePath)
-> IO (Either [CradleError] (ComponentOptions, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ([CradleError] -> Either [CradleError] (ComponentOptions, FilePath)
forall a b. a -> Either a b
Left [])

emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
emptyHscEnv IORef NameCache
nc FilePath
libDir = do
    HscEnv
env <- Maybe FilePath -> Ghc HscEnv -> IO HscEnv
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libDir) Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    HscEnv -> IO ()
initDynLinker HscEnv
env
    HscEnv -> IO HscEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ IORef NameCache -> HscEnv -> HscEnv
setNameCache IORef NameCache
nc HscEnv
env{ hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
env){useUnicode :: Bool
useUnicode = Bool
True } }

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

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

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


setNameCache :: IORef NameCache -> HscEnv -> HscEnv
setNameCache :: IORef NameCache -> HscEnv -> HscEnv
setNameCache IORef NameCache
nc HscEnv
hsc = HscEnv
hsc { hsc_NC :: IORef NameCache
hsc_NC = IORef NameCache
nc }

-- | Create a mapping from FilePaths to HscEnvEqs
newComponentCache
         :: Logger
         -> [String]       -- File extensions to consider
         -> Maybe FilePath -- Path to cradle
         -> NormalizedFilePath -- Path to file that caused the creation of this component
         -> HscEnv
         -> [(InstalledUnitId, DynFlags)]
         -> ComponentInfo
         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
newComponentCache :: Logger
-> [FilePath]
-> Maybe FilePath
-> NormalizedFilePath
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> ComponentInfo
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
newComponentCache Logger
logger [FilePath]
exts Maybe FilePath
cradlePath NormalizedFilePath
cfp HscEnv
hsc_env [(InstalledUnitId, DynFlags)]
uids ComponentInfo
ci = do
    let df :: DynFlags
df = ComponentInfo -> DynFlags
componentDynFlags ComponentInfo
ci
    let hscEnv' :: HscEnv
hscEnv' = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
df
                          , hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) { ic_dflags :: DynFlags
ic_dflags = DynFlags
df } }

    let newFunc :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newFunc = (HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq)
-> (FilePath
    -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq)
-> Maybe FilePath
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> IO HscEnvEq
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq Maybe FilePath
cradlePath
    HscEnvEq
henv <- HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newFunc HscEnv
hscEnv' [(InstalledUnitId, DynFlags)]
uids
    let targetEnv :: IdeResult HscEnvEq
targetEnv = ([], HscEnvEq -> Maybe HscEnvEq
forall a. a -> Maybe a
Just HscEnvEq
henv)
        targetDepends :: DependencyInfo
targetDepends = ComponentInfo -> DependencyInfo
componentDependencyInfo ComponentInfo
ci
        res :: (IdeResult HscEnvEq, DependencyInfo)
res = (IdeResult HscEnvEq
targetEnv, DependencyInfo
targetDepends)
    Logger -> Text -> IO ()
logDebug Logger
logger (Text
"New Component Cache HscEnvEq: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ((IdeResult HscEnvEq, DependencyInfo) -> FilePath
forall a. Show a => a -> FilePath
show (IdeResult HscEnvEq, DependencyInfo)
res))

    let mk :: Target -> IO [TargetDetails]
mk Target
t = [FilePath]
-> [FilePath]
-> TargetId
-> IdeResult HscEnvEq
-> DependencyInfo
-> IO [TargetDetails]
fromTargetId (DynFlags -> [FilePath]
importPaths DynFlags
df) [FilePath]
exts (Target -> TargetId
targetId Target
t) IdeResult 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)

    -- A special target for the file which caused this wonderful
    -- component to be created. In case the cradle doesn't list all the targets for
    -- the component, in which case things will be horribly broken anyway.
    -- Otherwise, we will immediately attempt to reload this module which
    -- causes an infinite loop and high CPU usage.
    let special_target :: TargetDetails
special_target = Target
-> IdeResult HscEnvEq
-> DependencyInfo
-> [NormalizedFilePath]
-> TargetDetails
TargetDetails (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
cfp) IdeResult HscEnvEq
targetEnv DependencyInfo
targetDepends [ComponentInfo -> NormalizedFilePath
componentFP ComponentInfo
ci]
    ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-> IO ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetDetails
special_targetTargetDetails -> [TargetDetails] -> [TargetDetails]
forall a. a -> [a] -> [a]
:[TargetDetails]
ctargets, (IdeResult HscEnvEq, DependencyInfo)
res)

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

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

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

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

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

-- | Set the cache-directory based on the ComponentOptions and a list of
-- internal packages.
-- For the exact reason, see Note [Avoiding bad interface files].
setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags
setCacheDir :: Logger
-> FilePath
-> [FilePath]
-> ComponentOptions
-> DynFlags
-> m DynFlags
setCacheDir Logger
logger FilePath
prefix [FilePath]
hscComponents ComponentOptions
comps DynFlags
dflags = do
    FilePath
cacheDir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO FilePath
getCacheDir FilePath
prefix ([FilePath]
hscComponents [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ComponentOptions -> [FilePath]
componentOptions ComponentOptions
comps)
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logInfo Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Using interface files cache dir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
cacheDir
    DynFlags -> m DynFlags
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
& FilePath -> DynFlags -> DynFlags
setHiDir FilePath
cacheDir
          DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& FilePath -> DynFlags -> DynFlags
setHieDir FilePath
cacheDir
          DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& FilePath -> DynFlags -> DynFlags
setODir FilePath
cacheDir


renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
renderCradleError :: NormalizedFilePath
-> CradleError -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderCradleError NormalizedFilePath
nfp (CradleError [FilePath]
_ ExitCode
_ec [FilePath]
t) =
  Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
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
DsError) NormalizedFilePath
nfp ([Text] -> Text
T.unlines ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack [FilePath]
t))

-- See Note [Multi Cradle Dependency Info]
type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])
type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))

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

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

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

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

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

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

    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
do_one FilePath
fp = (FilePath
fp,) (Maybe UTCTime -> (FilePath, Maybe UTCTime))
-> (Either IOException UTCTime -> Maybe UTCTime)
-> Either IOException UTCTime
-> (FilePath, 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 -> (FilePath, Maybe UTCTime))
-> IO (Either IOException UTCTime) -> IO (FilePath, 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)
tryIO (FilePath -> IO UTCTime
getModificationTime FilePath
fp)

-- | This function removes all the -package flags which refer to packages we
-- are going to deal with ourselves. For example, if a executable depends
-- on a library component, then this function will remove the library flag
-- from the package flags for the executable
--
-- There are several places in GHC (for example the call to hptInstances in
-- tcRnImports) which assume that all modules in the HPT have the same unit
-- ID. Therefore we create a fake one and give them all the same unit id.
removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
removeInplacePackages [InstalledUnitId]
us DynFlags
df = (DynFlags
df { packageFlags :: [PackageFlag]
packageFlags = [PackageFlag]
ps
                                  , thisInstalledUnitId :: InstalledUnitId
thisInstalledUnitId = InstalledUnitId
fake_uid }, [InstalledUnitId]
uids)
  where
    ([InstalledUnitId]
uids, [PackageFlag]
ps) = [Either InstalledUnitId PackageFlag]
-> ([InstalledUnitId], [PackageFlag])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((PackageFlag -> Either InstalledUnitId PackageFlag)
-> [PackageFlag] -> [Either InstalledUnitId PackageFlag]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> Either InstalledUnitId PackageFlag
go (DynFlags -> [PackageFlag]
packageFlags DynFlags
df))
    fake_uid :: InstalledUnitId
fake_uid = UnitId -> InstalledUnitId
toInstalledUnitId (FilePath -> UnitId
stringToUnitId FilePath
"fake_uid")
    go :: PackageFlag -> Either InstalledUnitId PackageFlag
go p :: PackageFlag
p@(ExposePackage FilePath
_ (UnitIdArg UnitId
u) ModRenaming
_) = if UnitId -> InstalledUnitId
toInstalledUnitId UnitId
u InstalledUnitId -> [InstalledUnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [InstalledUnitId]
us
                                                  then InstalledUnitId -> Either InstalledUnitId PackageFlag
forall a b. a -> Either a b
Left (UnitId -> InstalledUnitId
toInstalledUnitId UnitId
u)
                                                  else PackageFlag -> Either InstalledUnitId PackageFlag
forall a b. b -> Either a b
Right PackageFlag
p
    go PackageFlag
p = PackageFlag -> Either InstalledUnitId PackageFlag
forall a b. b -> Either a b
Right PackageFlag
p

-- | Memoize an IO function, with the characteristics:
--
--   * If multiple people ask for a result simultaneously, make sure you only compute it once.
--
--   * If there are exceptions, repeatedly reraise them.
--
--   * If the caller is aborted (async exception) finish computing it anyway.
memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO :: (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 (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. 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Map a (IO b)
mp, IO b
res)

-- | Throws if package flags are unsatisfiable
setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target])
setOptions :: ComponentOptions -> DynFlags -> m (DynFlags, [Target])
setOptions (ComponentOptions [FilePath]
theOpts FilePath
compRoot [FilePath]
_) DynFlags
dflags = do
    (DynFlags
dflags', [Target]
targets) <- [FilePath] -> DynFlags -> m (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [FilePath]
theOpts DynFlags
dflags
    let dflags'' :: DynFlags
dflags'' =
          DynFlags -> DynFlags
disableWarningsAsErrors (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
          -- disabled, generated directly by ghcide instead
          (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_WriteInterface (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
          -- disabled, generated directly by ghcide instead
          -- also, it can confuse the interface stale check
          DynFlags -> DynFlags
dontWriteHieFiles (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
          DynFlags -> DynFlags
setIgnoreInterfacePragmas (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
          DynFlags -> DynFlags
setLinkerOptions (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
setUpTypedHoles (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
          FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute FilePath
compRoot DynFlags
dflags'
    -- initPackages parses the -package flags and
    -- sets up the visibility for each component.
    -- Throws if a -package flag cannot be satisfied.
    (DynFlags
final_df, [InstalledUnitId]
_) <- IO (DynFlags, [InstalledUnitId]) -> m (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [InstalledUnitId])
 -> m (DynFlags, [InstalledUnitId]))
-> IO (DynFlags, [InstalledUnitId])
-> m (DynFlags, [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ IO (DynFlags, [InstalledUnitId])
-> IO (DynFlags, [InstalledUnitId])
forall a. IO a -> IO a
wrapPackageSetupException (IO (DynFlags, [InstalledUnitId])
 -> IO (DynFlags, [InstalledUnitId]))
-> IO (DynFlags, [InstalledUnitId])
-> IO (DynFlags, [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO (DynFlags, [InstalledUnitId])
initPackages DynFlags
dflags''
    (DynFlags, [Target]) -> m (DynFlags, [Target])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
final_df, [Target]
targets)


-- we don't want to generate object code so we compile to bytecode
-- (HscInterpreted) which implies LinkInMemory
-- HscInterpreted
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions DynFlags
df = DynFlags
df {
    ghcLink :: GhcLink
ghcLink   = GhcLink
LinkInMemory
  , hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing
  , ghcMode :: GhcMode
ghcMode = GhcMode
CompManager
  }

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 :: FilePath -> DynFlags -> DynFlags
setHiDir FilePath
f DynFlags
d =
    -- override user settings to avoid conflicts leading to recompilation
    DynFlags
d { hiDir :: Maybe FilePath
hiDir      = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f}

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

getCacheDir :: String -> [String] -> IO FilePath
getCacheDir :: FilePath -> [FilePath] -> IO FilePath
getCacheDir FilePath
prefix [FilePath]
opts = XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache (FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
opts_hash)
    where
        -- Create a unique folder per set of different GHC options, assuming that each different set of
        -- GHC options will create incompatible interface files.
        opts_hash :: FilePath
opts_hash = ByteString -> FilePath
B.unpack (ByteString -> FilePath) -> ByteString -> FilePath
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 ((FilePath -> ByteString) -> [FilePath] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ByteString
B.pack [FilePath]
opts)

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

notifyUserImplicitCradle:: FilePath -> FromServerMessage
notifyUserImplicitCradle :: FilePath -> FromServerMessage
notifyUserImplicitCradle FilePath
fp =
    ShowMessageNotification -> FromServerMessage
NotShowMessage (ShowMessageNotification -> FromServerMessage)
-> ShowMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
    Text
-> ServerMethod -> ShowMessageParams -> ShowMessageNotification
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" ServerMethod
WindowShowMessage (ShowMessageParams -> ShowMessageNotification)
-> ShowMessageParams -> ShowMessageNotification
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
MtInfo (Text -> ShowMessageParams) -> Text -> ShowMessageParams
forall a b. (a -> b) -> a -> b
$
      Text
"No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Text
".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\
      \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."

notifyCradleLoaded :: FilePath -> FromServerMessage
notifyCradleLoaded :: FilePath -> FromServerMessage
notifyCradleLoaded FilePath
fp =
    CustomServerNotification -> FromServerMessage
NotCustomServer (CustomServerNotification -> FromServerMessage)
-> CustomServerNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
    Text -> ServerMethod -> Value -> CustomServerNotification
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" (Text -> ServerMethod
CustomServerMethod Text
cradleLoadedMethod) (Value -> CustomServerNotification)
-> Value -> CustomServerNotification
forall a b. (a -> b) -> a -> b
$
    FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON FilePath
fp

cradleLoadedMethod :: T.Text
cradleLoadedMethod :: Text
cradleLoadedMethod = Text
"ghcide/cradle/loaded"

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

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

instance Exception PackageSetupException

-- | Wrap any exception as a 'PackageSetupException'
wrapPackageSetupException :: IO a -> IO a
wrapPackageSetupException :: IO a -> IO a
wrapPackageSetupException = (SomeException -> IO a) -> IO a -> IO a
forall (m :: * -> *) a.
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. (MonadThrow m, Exception e) => e -> m a
throwIO PackageSetupException
pkgE
  SomeException
e -> (PackageSetupException -> IO a
forall (m :: * -> *) e a. (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
. FilePath -> PackageSetupException
PackageSetupException (FilePath -> PackageSetupException)
-> (SomeException -> FilePath)
-> SomeException
-> PackageSetupException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> FilePath
forall a. Show a => a -> FilePath
show) SomeException
e

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

renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderPackageSetupException :: FilePath
-> PackageSetupException
-> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
renderPackageSetupException FilePath
fp PackageSetupException
e =
    Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
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
DsError) (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
fp) (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageSetupException -> FilePath
showPackageSetupException PackageSetupException
e)