{-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-x-partial #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Initialise the GHC session for one or more home units.
--
-- This code is inspired of HLS's session initialisation.
-- It would be great to extract common functions in the future.
module GHC.Debugger.Session (
  parseHomeUnitArguments,
  setupHomeUnitGraph,
  validateUnitsWays,
  TargetDetails(..),
  Target(..),
  toGhcTarget,
  CacheDirs(..),
  getCacheDirs,
  -- * Debugger's Interactive Home Unit
  interactiveGhcDebuggerUnitId,
  getInteractiveDebuggerDynFlags,
  setInteractiveDebuggerDynFlags,
  -- * DynFlags modifications
  setWorkingDirectory,
  setCacheDirs,
  setBytecodeBackend,
  enableByteCodeGeneration,
  enableExternalInterpreter,
  enableDynamicDebuggee,
  setPgmI, addOptI,
  setDynFlagWays,
  makeDynFlagsAbsoluteOverall,
  resumeExec,
  exposeModGraphUnitsInInteractiveGhcDebuggerUnit,
  graphsUnits,
  compileModuleWithDepsInHpt,
  home_unit_dflags,
  packageImportDecl,
  withUnliftGhc,
  annotateCallStackGhc,
  lookupUnitPackageQualifier,
  fixHomeUnitsDynFlagsForIIDecl, getPgmI,
  initUniqSupplyIO
  )
  where

#if MIN_VERSION_ghc(9,14,2)
import Data.Function ((&))
#endif
import Control.Applicative ((<|>))
import Control.Exception (assert)
import Control.Monad
import Control.Monad.Identity
import Control.Monad.IO.Class
import qualified Crypto.Hash.SHA1                    as H
import qualified Data.ByteString.Base16              as B16
import qualified Data.ByteString.Char8               as B
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
#if MIN_VERSION_ghc(10,1,0)
import Data.IORef (newIORef)
#endif
import qualified Data.List as L
import qualified Data.List as List
import qualified Data.Containers.ListUtils as ListUtils
import GHC.ResponseFile (expandResponse)
import HIE.Bios.Environment as HIE
import System.FilePath
import Data.Time
import qualified System.Directory as Directory
import qualified System.Environment as Env

import qualified GHC
import GHC.Platform.Ways
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Monad
import qualified GHC.Driver.Session as GHC
import GHC.Utils.Monad as GHC
import GHC.Unit.Home.Graph
import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if MIN_VERSION_ghc(10,1,0)
import GHC.Unit.External.Index (UnitIndexCache)
#endif
import GHC.Unit.Types
import qualified GHC.Unit.State                        as State
import GHC.Driver.Env
import GHC.Types.SrcLoc
import Language.Haskell.Syntax.Module.Name
import qualified Data.Foldable as Foldable
import qualified GHC.Unit.Home.Graph as HUG
import qualified Data.Set as Set
import Data.Maybe
import GHC.Types.Target (InputFileBuffer)
import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts), ideclPkgQual, ImportDecl, GhcPs)
import Data.Set (Set)
import qualified GHC.Unit as GHC
import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey)
import GHC.Driver.Make
import GHC.Unit.Home.ModInfo (HomeModInfo(..))
import qualified GHC.Driver.Errors.Types as GHC
import System.Directory (doesFileExist)
import qualified GHC.Types.Error as GHC
import qualified GHC.Utils.Error as GHC
import GHC.Driver.Pipeline (compileOne)
import qualified GHC.Unit.Home.ModInfo as GHC
import GHC.Utils.TmpFs
import Data.Foldable (for_)
import GHC.Plugins (SourceError, try, RawPkgQual (..), HasCallStack, FastString, mkFastString, lookupUnitId)
#if MIN_VERSION_ghc(10,1,0)
import GHC.Types.SourceText (SourceText (..))
#else
import GHC.Types.SourceText (StringLiteral(..), SourceText (..))
#endif
import GHC.Stack.Annotation
import GHC.Stack (callStack)
import GHC.Settings (ToolSettings(..))
import qualified GHC.Types.Unique.Supply as GHC
import Data.Containers.ListUtils (nubOrd)

-- | Throws if package flags are unsatisfiable
parseHomeUnitArguments :: GhcMonad m
    => FilePath -- ^ Main entry point function
    -> FilePath -- ^ Component root. Important for multi-package cabal projects.
    -> [String]
    -> [String] -- ghcInvocation
    -> DynFlags
    -> FilePath -- ^ root dir, see Note [Root Directory]
    -> m (NonEmpty.NonEmpty (DynFlags, [GHC.Target]))
parseHomeUnitArguments :: forall (m :: * -> *).
GhcMonad m =>
FilePath
-> FilePath
-> [FilePath]
-> [FilePath]
-> DynFlags
-> FilePath
-> m (NonEmpty (DynFlags, [Target]))
parseHomeUnitArguments FilePath
cfp FilePath
compRoot [FilePath]
units [FilePath]
theOpts DynFlags
dflags FilePath
rootDir = do
    ((theOpts',_errs,_warns),_units) <- [Flag (CmdLineP [ZonkAny 0])]
-> [ZonkAny 0]
-> [Located FilePath]
-> m (([Located FilePath], [Err], [Warn]), [ZonkAny 0])
forall s (m :: * -> *).
MonadIO m =>
[Flag (CmdLineP s)]
-> s
-> [Located FilePath]
-> m (([Located FilePath], [Err], [Warn]), s)
GHC.processCmdLineP [] [] ((FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Located FilePath
forall e. e -> Located e
noLoc [FilePath]
theOpts)
    case NonEmpty.nonEmpty units of
      Just NonEmpty FilePath
us -> NonEmpty FilePath -> m (NonEmpty (DynFlags, [Target]))
forall {t :: * -> *} {m :: * -> *}.
(Traversable t, GhcMonad m) =>
t FilePath -> m (t (DynFlags, [Target]))
initMulti NonEmpty FilePath
us
      Maybe (NonEmpty FilePath)
Nothing -> do
        (df, targets) <- [FilePath] -> m (DynFlags, [Target])
forall {m :: * -> *}.
GhcMonad m =>
[FilePath] -> m (DynFlags, [Target])
initOne ((Located FilePath -> FilePath) -> [Located FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Located FilePath -> FilePath
forall l e. GenLocated l e -> e
unLoc [Located FilePath]
theOpts')
        -- A special target for the file which caused this wonderful
        -- component to be created. In case the cradle doesn't list all the targets for
        -- the component, in which case things will be horribly broken anyway.
        --
        -- When we have a singleComponent that is caused to be loaded due to a
        -- file, we assume the file is part of that component. This is useful
        -- for bare GHC sessions, such as many of the ones used in the testsuite
        --
        -- We don't do this when we have multiple components, because each
        -- component better list all targets or there will be anarchy.
        -- It is difficult to know which component to add our file to in
        -- that case.
        -- Multi unit arguments are likely to come from cabal, which
        -- does list all targets.
        --
        -- If we don't end up with a target for the current file in the end, then
        -- we will report it as an error for that file
        let abs_fp = FilePath
rootDir FilePath -> FilePath -> FilePath
</> FilePath
cfp
        -- Canonicalize! Why? Because the targets we get from the cradle are normalised and if we don't normalise the "special target" then they aren't deduplicated properly.
        canon_fp <- liftIO $ Directory.canonicalizePath abs_fp
        let special_target = DynFlags -> FilePath -> Target
mkSimpleTarget DynFlags
df FilePath
canon_fp
        pure $ (df, if null targets then [special_target] else targets) NonEmpty.:| []
    where
      initMulti :: t FilePath -> m (t (DynFlags, [Target]))
initMulti t FilePath
unitArgFiles =
        t FilePath
-> (FilePath -> m (DynFlags, [Target]))
-> m (t (DynFlags, [Target]))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t FilePath
unitArgFiles ((FilePath -> m (DynFlags, [Target]))
 -> m (t (DynFlags, [Target])))
-> (FilePath -> m (DynFlags, [Target]))
-> m (t (DynFlags, [Target]))
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
          args <- IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
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] -> IO [FilePath]
expandResponse [FilePath
f]
          initOne args
      initOne :: [FilePath] -> m (DynFlags, [Target])
initOne [FilePath]
this_opts = do
        (dflags', targets') <- [FilePath] -> DynFlags -> m (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [FilePath]
this_opts DynFlags
dflags
        let root = case DynFlags -> Maybe FilePath
workingDirectory DynFlags
dflags' of
              Maybe FilePath
Nothing   -> FilePath
compRoot
              Just FilePath
wdir -> FilePath
compRoot FilePath -> FilePath -> FilePath
</> FilePath
wdir
        root_canon <- liftIO $ Directory.canonicalizePath root
        let targets = FilePath -> [Target] -> [Target]
HIE.makeTargetsAbsolute FilePath
root_canon [Target]
targets'
        cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts
        let dflags'' =
              FilePath -> DynFlags -> DynFlags
makeDynFlagsDirsAbsolute FilePath
compRoot (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              FilePath -> DynFlags -> DynFlags
setWorkingDirectory FilePath
root (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              CacheDirs -> DynFlags -> DynFlags
setCacheDirs CacheDirs
cacheDirs (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
enableByteCodeGeneration (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              DynFlags -> DynFlags
setBytecodeBackend (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$
              FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute FilePath
compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
              DynFlags
dflags'
        return (dflags'', targets)

setupHomeUnitGraph :: GhcMonad m => [(DynFlags, [GHC.Target])] -> m ()
setupHomeUnitGraph :: forall (m :: * -> *). GhcMonad m => [(DynFlags, [Target])] -> m ()
setupHomeUnitGraph [(DynFlags, [Target])]
flagsAndTargets = do
  hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  (hsc_env', targetDetails) <- liftIO $ setupMultiHomeUnitGhcSession [".hs", ".lhs"] hsc_env flagsAndTargets
  GHC.setSession hsc_env'
  GHC.setTargets (fmap toGhcTarget targetDetails)

-- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's.
-- The first 'DynFlags' are the 'DynFlags' for the interactive session.
createHomeUnitGraph :: GHC.Logger -> UnitEnv -> [DynFlags] -> IO HomeUnitGraph
createHomeUnitGraph :: Logger -> UnitEnv -> [DynFlags] -> IO HomeUnitGraph
createHomeUnitGraph Logger
logger UnitEnv
_uenv [DynFlags]
unitDflags = do
  let home_units :: Set UnitId
home_units = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (DynFlags -> UnitId) -> [DynFlags] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map DynFlags -> UnitId
homeUnitId_ [DynFlags]
unitDflags

  unitEnvList <- ((DynFlags -> IO (UnitId, HomeUnitEnv))
 -> [DynFlags] -> IO [(UnitId, HomeUnitEnv)])
-> [DynFlags]
-> (DynFlags -> IO (UnitId, HomeUnitEnv))
-> IO [(UnitId, HomeUnitEnv)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DynFlags -> IO (UnitId, HomeUnitEnv))
-> [DynFlags] -> IO [(UnitId, HomeUnitEnv)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [DynFlags]
unitDflags ((DynFlags -> IO (UnitId, HomeUnitEnv))
 -> IO [(UnitId, HomeUnitEnv)])
-> (DynFlags -> IO (UnitId, HomeUnitEnv))
-> IO [(UnitId, HomeUnitEnv)]
forall a b. (a -> b) -> a -> b
$ \ DynFlags
dflags -> do
    let uid :: UnitId
uid = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags
#if MIN_VERSION_ghc(10,1,0)
    hue <- setupNewHomeUnitEnv home_units logger dflags (ue_uic _uenv)
#else
    hue <- Set UnitId
-> Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO HomeUnitEnv
setupNewHomeUnitEnv Set UnitId
home_units Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
forall a. Maybe a
Nothing
#endif
    assert (homeUnitId_ (homeUnitEnv_dflags hue) == uid) $
      pure (uid, hue)

  pure $ unitEnv_new (Map.fromList unitEnvList)

-- | See Note [ Ambiguous Package Qualified Imports Workaround ]
fixHomeUnitsDynFlagsForIIDecl :: Ghc ()
fixHomeUnitsDynFlagsForIIDecl :: Ghc ()
fixHomeUnitsDynFlagsForIIDecl = do
  (HscEnv -> HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> Ghc ()) -> (HscEnv -> HscEnv) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG ((HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv)
-> (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ \ HomeUnitGraph
hug -> do
    let manyHomeUnits :: Bool
manyHomeUnits = Set UnitId -> Int
forall a. Set a -> Int
Set.size (HomeUnitGraph -> Set UnitId
HUG.allUnits HomeUnitGraph
hug) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    let h :: HomeUnitEnv -> HomeUnitEnv
h HomeUnitEnv
hue = HomeUnitEnv
hue { homeUnitEnv_dflags = fixFlagsForIIDecl manyHomeUnits (homeUnitEnv_dflags hue) }
    Identity HomeUnitGraph -> HomeUnitGraph
forall a. Identity a -> a
runIdentity (Identity HomeUnitGraph -> HomeUnitGraph)
-> (HomeUnitGraph -> Identity HomeUnitGraph)
-> HomeUnitGraph
-> HomeUnitGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> HomeUnitEnv -> Identity HomeUnitEnv)
-> HomeUnitGraph -> Identity HomeUnitGraph
forall (f :: * -> *) a b.
Applicative f =>
(UnitId -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b)
unitEnv_traverseWithKey ((HomeUnitEnv -> Identity HomeUnitEnv)
-> UnitId -> HomeUnitEnv -> Identity HomeUnitEnv
forall a b. a -> b -> a
const ((HomeUnitEnv -> Identity HomeUnitEnv)
 -> UnitId -> HomeUnitEnv -> Identity HomeUnitEnv)
-> (HomeUnitEnv -> Identity HomeUnitEnv)
-> UnitId
-> HomeUnitEnv
-> Identity HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> Identity HomeUnitEnv
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HomeUnitEnv -> Identity HomeUnitEnv)
-> (HomeUnitEnv -> HomeUnitEnv)
-> HomeUnitEnv
-> Identity HomeUnitEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeUnitEnv -> HomeUnitEnv
h) (HomeUnitGraph -> HomeUnitGraph) -> HomeUnitGraph -> HomeUnitGraph
forall a b. (a -> b) -> a -> b
$ HomeUnitGraph
hug
  where
    -- | Makes package names of home units unique and removes hidden modules.
    fixFlagsForIIDecl :: Bool -> DynFlags -> DynFlags
    fixFlagsForIIDecl :: Bool -> DynFlags -> DynFlags
fixFlagsForIIDecl Bool
False DynFlags
df | Just{} <- DynFlags -> Maybe FilePath
thisPackageName DynFlags
df = DynFlags
df {hiddenModules = mempty}
    -- TODO #288: pick more user-friendly names.
    fixFlagsForIIDecl Bool
_manyHUnits DynFlags
dflags = DynFlags
dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags))
        , hiddenModules = mempty}

-- | The first argument should contain the home units the new @HomeUnitEnv@ depends on (@allUnits (hsc_HUG env)@ is always safe to give).
--   The actual dependencies are specified by the @packageFlags@ in the @DynFlags@ argument.
setupNewHomeUnitEnv
  :: Set UnitId -> GHC.Logger -> DynFlags
#if MIN_VERSION_ghc(10,1,0)
  -> UnitIndexCache
#else
  -> Maybe [GHC.UnitDatabase UnitId]
#endif
  -> IO HomeUnitEnv
setupNewHomeUnitEnv :: Set UnitId
-> Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO HomeUnitEnv
setupNewHomeUnitEnv Set UnitId
hug_keys Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_dbs = do
  emptyHpt <- IO HomePackageTable
emptyHomePackageTable
#if MIN_VERSION_ghc(10,1,0)
  (unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs hug_keys
  updated_dflags <- GHC.updatePlatformConstants dflags mconstants
  pure $ mkHomeUnitEnv unit_state updated_dflags emptyHpt (Just home_unit)
#else
  (dbs,unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs hug_keys
  updated_dflags <- GHC.updatePlatformConstants dflags mconstants
  pure $ mkHomeUnitEnv unit_state (Just dbs) updated_dflags emptyHpt (Just home_unit)
#endif

-- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this
-- 'HscEnv'.
-- We assume the 'HscEnv' is "empty", e.g. wasn't already used to compile
-- anything.
initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv
initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv
initHomeUnitEnv [DynFlags]
unitDflags HscEnv
env = do

  initial_home_graph <- Logger -> UnitEnv -> [DynFlags] -> IO HomeUnitGraph
createHomeUnitGraph (HscEnv -> Logger
hsc_logger HscEnv
env) (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env) [DynFlags]
unitDflags

  -- We need one of the units to be the `ue_currentUnit`: by default it's "main", but we don't create such a unit and Ghc panics.
  addInteractiveGhcDebuggerUnit (Set.toList . allUnits $ initial_home_graph) $ hscUpdateHUG (const initial_home_graph) env

-- | Adds or refreshes the @interactiveGhcDebuggerUnit@ passing the first
-- argument as @ExposePackage@ flags.
addInteractiveGhcDebuggerUnit :: [UnitId] -> HscEnv -> IO HscEnv
addInteractiveGhcDebuggerUnit :: [UnitId] -> HscEnv -> IO HscEnv
addInteractiveGhcDebuggerUnit [UnitId]
exposed HscEnv
env = do
  let dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
env
  let initial_home_graph :: HomeUnitGraph
initial_home_graph = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
env
  -- We set up the interactive debugger home unit after the other home units
  -- have been initialised.
  -- This allows us to reuse the package databases and their respective visibilities.
  interactiveHomeUnit <- do
    let
      interactiveDynFlags :: DynFlags
interactiveDynFlags = DynFlags
dflags0
        { homeUnitId_ = interactiveGhcDebuggerUnitId
        , importPaths = []
        , packageFlags =
            [ ExposePackage
                (unitIdString uid)
                (UnitIdArg $ RealUnit (Definite uid))
                (ModRenaming True [])
            | uid <- exposed
            , uid /= rtsUnitId
            , uid /= ghcInternalUnitId
            , uid /= interactiveGhcDebuggerUnitId
            -- TODO: other uids to filter?
            ]
        , packageDBFlags = concatPackageDbStacksUsingLongestCommonPrefix $
            (fmap (packageDBFlags . homeUnitEnv_dflags) (Foldable.toList initial_home_graph))
        }

#if MIN_VERSION_ghc(10,1,0)
    setupNewHomeUnitEnv (allUnits initial_home_graph) (hsc_logger env) interactiveDynFlags (hscUIC env)
#else
    let cached_unit_dbs :: [UnitDatabase UnitId]
cached_unit_dbs = [[UnitDatabase UnitId]] -> [UnitDatabase UnitId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnitDatabase UnitId]] -> [UnitDatabase UnitId])
-> ([HomeUnitEnv] -> [[UnitDatabase UnitId]])
-> [HomeUnitEnv]
-> [UnitDatabase UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [UnitDatabase UnitId]] -> [[UnitDatabase UnitId]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [UnitDatabase UnitId]] -> [[UnitDatabase UnitId]])
-> ([HomeUnitEnv] -> [Maybe [UnitDatabase UnitId]])
-> [HomeUnitEnv]
-> [[UnitDatabase UnitId]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HomeUnitEnv -> Maybe [UnitDatabase UnitId])
-> [HomeUnitEnv] -> [Maybe [UnitDatabase UnitId]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs ([HomeUnitEnv] -> [UnitDatabase UnitId])
-> [HomeUnitEnv] -> [UnitDatabase UnitId]
forall a b. (a -> b) -> a -> b
$ HomeUnitGraph -> [HomeUnitEnv]
forall a. UnitEnvGraph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList HomeUnitGraph
initial_home_graph
    Set UnitId
-> Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO HomeUnitEnv
setupNewHomeUnitEnv (HomeUnitGraph -> Set UnitId
allUnits HomeUnitGraph
initial_home_graph) (HscEnv -> Logger
hsc_logger HscEnv
env) DynFlags
interactiveDynFlags ([UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
cached_unit_dbs)
#endif

  let home_unit_graph =
        UnitId -> HomeUnitEnv -> HomeUnitGraph -> HomeUnitGraph
forall v. UnitId -> v -> UnitEnvGraph v -> UnitEnvGraph v
HUG.unitEnv_insert UnitId
interactiveGhcDebuggerUnitId HomeUnitEnv
interactiveHomeUnit HomeUnitGraph
initial_home_graph

  let interactiveDFlags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
interactiveHomeUnit
  let unit_env = (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env)
        { ue_home_unit_graph = home_unit_graph
        , ue_current_unit    = interactiveGhcDebuggerUnitId
        , ue_platform        = targetPlatform interactiveDFlags
        , ue_namever         = GHC.ghcNameVersion interactiveDFlags
        }
  pure $ hscSetFlags interactiveDFlags $ hscSetUnitEnv unit_env env
  where
    -- inlined from GHCi. Patiently waiting for a nice Dev UX to units and flags...
    concatPackageDbStacksUsingLongestCommonPrefix :: Ord a => [[a]] -> [a]
    concatPackageDbStacksUsingLongestCommonPrefix :: forall a. Ord a => [[a]] -> [a]
concatPackageDbStacksUsingLongestCommonPrefix (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. [a] -> [a]
reverse -> [[a]]
stacks) =
      let
        -- O (m * n)
        -- m ... Number of PackageDBFlag stacks
        -- n ... Size of the stacks
        longestCommonPrefix :: [[a]] -> [a]
longestCommonPrefix =
          ([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
forall a. HasCallStack => [a] -> a
List.head ([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
List.takeWhile (((a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.all ((a -> Bool) -> [a] -> Bool)
-> ([a] -> a -> Bool) -> [a] -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> ([a] -> a) -> [a] -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. HasCallStack => [a] -> a
List.head) ([a] -> [a] -> Bool) -> ([a] -> [a]) -> [a] -> Bool
forall a b. ([a] -> a -> b) -> ([a] -> a) -> [a] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
List.tail) ([[a]] -> [[a]]) -> ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
List.transpose
        prefix :: [a]
prefix =
          [[a]] -> [a]
longestCommonPrefix [[a]]
stacks
      in
        [a]
prefix [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. Ord a => [a] -> [a]
nubOrd (([a] -> [a]) -> [[a]] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
List.drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
prefix)) [[a]]
stacks)

-- | Sets the units from the @ModuleGraph@ as the exposed ones for @InteractiveGhcDebuggerUnit@.
--
--   See Note [Must explicitly expose module graph units].
exposeModGraphUnitsInInteractiveGhcDebuggerUnit :: Ghc ()
exposeModGraphUnitsInInteractiveGhcDebuggerUnit :: Ghc ()
exposeModGraphUnitsInInteractiveGhcDebuggerUnit =
  (HscEnv -> Ghc HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> m HscEnv) -> m ()
modifySessionM ((HscEnv -> Ghc HscEnv) -> Ghc ())
-> (HscEnv -> Ghc HscEnv) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \ HscEnv
env -> do
    IO HscEnv -> Ghc HscEnv
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> Ghc HscEnv) -> IO HscEnv -> Ghc HscEnv
forall a b. (a -> b) -> a -> b
$ [UnitId] -> HscEnv -> IO HscEnv
addInteractiveGhcDebuggerUnit (HscEnv -> [UnitId]
graphsUnits HscEnv
env) HscEnv
env

-- | Extracts @UnitId@s from @ModuleGraph@ and @HomeUnitGraph@.
graphsUnits :: HscEnv -> [UnitId]
graphsUnits :: HscEnv -> [UnitId]
graphsUnits HscEnv
env = [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
ListUtils.nubOrd ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [UnitId]
modGraphUIDs [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
hugPreloadUIDs
  where
    -- [TODO](https://github.com/well-typed/haskell-debugger/issues/351): redundant?
    modGraphUIDs :: [UnitId]
modGraphUIDs = ((ModuleGraphNode -> Maybe UnitId) -> [ModuleGraphNode] -> [UnitId]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` ModuleGraph -> [ModuleGraphNode]
mg_mss ModuleGraph
mod_graph) ((ModuleGraphNode -> Maybe UnitId) -> [UnitId])
-> (ModuleGraphNode -> Maybe UnitId) -> [UnitId]
forall a b. (a -> b) -> a -> b
$ \case
         UnitNode  [UnitId]
_deps UnitId
uid -> UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
uid
         ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
modl -> UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> UnitId
mnkUnitId (ModNodeKeyWithUid -> UnitId) -> ModNodeKeyWithUid -> UnitId
forall a b. (a -> b) -> a -> b
$ ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
modl
         InstantiationNode UnitId
uid InstantiatedUnit
_ -> UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
uid
         LinkNode [NodeKey]
_ UnitId
_ -> Maybe UnitId
forall a. Maybe a
Nothing
    mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
    hug :: HomeUnitGraph
hug = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
env
    -- external deps do not always show up in the ModuleGraph
    -- (e.g. when we are given a cached session),
    -- so we also include the preloadUnits of the home units.
    hugPreloadUIDs :: [UnitId]
hugPreloadUIDs =
      [ UnitId
uid
      | (UnitId
_,HomeUnitEnv
hue) <- HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
forall a. UnitEnvGraph a -> [(UnitId, a)]
unitEnv_assocs HomeUnitGraph
hug
      , UnitId
uid <- UnitState -> [UnitId]
GHC.preloadUnits (UnitState -> [UnitId]) -> UnitState -> [UnitId]
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue ]

-- | WARNING: callback is not to be used from other threads.
withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
withUnliftGhc :: forall b a. ((Ghc b -> IO b) -> IO a) -> Ghc a
withUnliftGhc (Ghc b -> IO b) -> IO a
k = (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
reifyGhc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \ Session
s -> (Ghc b -> IO b) -> IO a
k ((Ghc b -> Session -> IO b) -> Session -> Ghc b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ghc b -> Session -> IO b
forall a. Ghc a -> Session -> IO a
reflectGhc Session
s)

annotateCallStackGhc :: HasCallStack => Ghc a -> Ghc a
annotateCallStackGhc :: forall a. HasCallStack => Ghc a -> Ghc a
annotateCallStackGhc Ghc a
m = let x :: CallStack
x = CallStack
HasCallStack => CallStack
callStack in ((Ghc a -> IO a) -> IO a) -> Ghc a
forall b a. ((Ghc b -> IO b) -> IO a) -> Ghc a
withUnliftGhc (((Ghc a -> IO a) -> IO a) -> Ghc a)
-> ((Ghc a -> IO a) -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \Ghc a -> IO a
k -> CallStack -> IO a -> IO a
forall a b. Show a => a -> IO b -> IO b
annotateStackShowIO CallStack
x (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Ghc a -> IO a
k Ghc a
m


-- | Setup the given 'HscEnv' to hold a 'UnitEnv'
-- with all the given components.
-- We return the modified 'HscEnv' and all the 'TargetDetails' for
-- the given 'GHC.Target's.
setupMultiHomeUnitGhcSession
         :: [String]           -- ^ File extensions to consider. This is mostly a remnant of HLS.
         -> HscEnv             -- ^ An empty HscEnv that we can use the setup the session.
         -> [(DynFlags, [GHC.Target])]    -- ^ New components to be loaded. Expected to be non-empty.
         -> IO (HscEnv, [TargetDetails])
setupMultiHomeUnitGhcSession :: [FilePath]
-> HscEnv -> [(DynFlags, [Target])] -> IO (HscEnv, [TargetDetails])
setupMultiHomeUnitGhcSession [FilePath]
exts HscEnv
hsc_env [(DynFlags, [Target])]
cis = IO (HscEnv, [TargetDetails]) -> IO (HscEnv, [TargetDetails])
forall a. HasCallStack => IO a -> IO a
annotateCallStackIO (IO (HscEnv, [TargetDetails]) -> IO (HscEnv, [TargetDetails]))
-> IO (HscEnv, [TargetDetails]) -> IO (HscEnv, [TargetDetails])
forall a b. (a -> b) -> a -> b
$ do
    let dfs :: [DynFlags]
dfs = ((DynFlags, [Target]) -> DynFlags)
-> [(DynFlags, [Target])] -> [DynFlags]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags, [Target]) -> DynFlags
forall a b. (a, b) -> a
fst [(DynFlags, [Target])]
cis

    hscEnv' <- [DynFlags] -> HscEnv -> IO HscEnv
initHomeUnitEnv [DynFlags]
dfs HscEnv
hsc_env
    -- TODO: this should be reported
    -- _ <- maybeToList $ GHC.checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
    ts <- forM cis $ \(DynFlags
df, [Target]
targets) -> do
      -- evaluate $ liftRnf rwhnf targets

      let mk :: Target -> IO [TargetDetails]
mk Target
t = [FilePath]
-> [FilePath]
-> UnitId
-> TargetId
-> Maybe (InputFileBuffer, UTCTime)
-> IO [TargetDetails]
fromTargetId (DynFlags -> [FilePath]
importPaths DynFlags
df) [FilePath]
exts (DynFlags -> UnitId
homeUnitId_ DynFlags
df) (Target -> TargetId
GHC.targetId Target
t) (Target -> Maybe (InputFileBuffer, UTCTime)
GHC.targetContents Target
t)
      ctargets <- (Target -> IO [TargetDetails]) -> [Target] -> IO [TargetDetails]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Target -> IO [TargetDetails]
mk [Target]
targets

      return (ListUtils.nubOrdOn targetTarget ctargets)
    pure (hscEnv', concat ts)

-- | Find and return the ways in which the home units are built.
-- INVARIANT: All home units are built with the same 'Ways'
validateUnitsWays :: NonEmpty.NonEmpty DynFlags -> IO Ways
validateUnitsWays :: NonEmpty DynFlags -> IO Ways
validateUnitsWays NonEmpty DynFlags
flags = do
    let unitWays :: NonEmpty Ways
unitWays  = (DynFlags -> Ways) -> NonEmpty DynFlags -> NonEmpty Ways
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map DynFlags -> Ways
ways NonEmpty DynFlags
flags
        firstWays :: Ways
firstWays = NonEmpty Ways -> Ways
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Ways
unitWays
        restWays :: [Ways]
restWays  = NonEmpty Ways -> [Ways]
forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty Ways
unitWays
    if (Ways -> Bool) -> [Ways] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Ways -> Ways -> Bool
forall a. Eq a => a -> a -> Bool
== Ways
firstWays) [Ways]
restWays
        then Ways -> IO Ways
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ways
firstWays
        else FilePath -> IO Ways
forall a. HasCallStack => FilePath -> a
error FilePath
"Unexpected: the home units have different ways! Not supported, see GHC#26765"

data TargetDetails = TargetDetails
  { TargetDetails -> Target
targetTarget :: Target
  -- ^ Simplified version of 'TargetId', storing enough information
  --
  , TargetDetails -> [FilePath]
targetLocations :: [FilePath]
  -- ^ The physical location of 'targetTarget'.
  -- Contains '-boot' file locations.
  -- At this moment in time, these are unused, but could be used to create
  -- convenient lookup table from 'FilePath' to 'TargetDetails'.
  , TargetDetails -> UnitId
targetUnitId :: UnitId
  -- ^ UnitId of 'targetTarget'.
  , TargetDetails -> Maybe (InputFileBuffer, UTCTime)
targetContents :: Maybe (InputFileBuffer, UTCTime)
  }

-- | A simplified view on a 'TargetId'.
--
-- Implements 'Ord' and 'Show' which can be convenient.
data Target = TargetModule ModuleName | TargetFile FilePath
  deriving ( Target -> Target -> Bool
(Target -> Target -> Bool)
-> (Target -> Target -> Bool) -> Eq Target
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Target -> Target -> Bool
== :: Target -> Target -> Bool
$c/= :: Target -> Target -> Bool
/= :: Target -> Target -> Bool
Eq, Eq Target
Eq Target =>
(Target -> Target -> Ordering)
-> (Target -> Target -> Bool)
-> (Target -> Target -> Bool)
-> (Target -> Target -> Bool)
-> (Target -> Target -> Bool)
-> (Target -> Target -> Target)
-> (Target -> Target -> Target)
-> Ord Target
Target -> Target -> Bool
Target -> Target -> Ordering
Target -> Target -> Target
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Target -> Target -> Ordering
compare :: Target -> Target -> Ordering
$c< :: Target -> Target -> Bool
< :: Target -> Target -> Bool
$c<= :: Target -> Target -> Bool
<= :: Target -> Target -> Bool
$c> :: Target -> Target -> Bool
> :: Target -> Target -> Bool
$c>= :: Target -> Target -> Bool
>= :: Target -> Target -> Bool
$cmax :: Target -> Target -> Target
max :: Target -> Target -> Target
$cmin :: Target -> Target -> Target
min :: Target -> Target -> Target
Ord, Int -> Target -> FilePath -> FilePath
[Target] -> FilePath -> FilePath
Target -> FilePath
(Int -> Target -> FilePath -> FilePath)
-> (Target -> FilePath)
-> ([Target] -> FilePath -> FilePath)
-> Show Target
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> Target -> FilePath -> FilePath
showsPrec :: Int -> Target -> FilePath -> FilePath
$cshow :: Target -> FilePath
show :: Target -> FilePath
$cshowList :: [Target] -> FilePath -> FilePath
showList :: [Target] -> FilePath -> FilePath
Show )

-- | Turn a 'TargetDetails' into a 'GHC.Target'.
toGhcTarget :: TargetDetails -> GHC.Target
toGhcTarget :: TargetDetails -> Target
toGhcTarget (TargetDetails Target
tid [FilePath]
_ UnitId
uid Maybe (InputFileBuffer, UTCTime)
cts) = case Target
tid of
  TargetModule ModuleName
modl -> TargetId
-> Bool -> UnitId -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
modl) Bool
True UnitId
uid Maybe (InputFileBuffer, UTCTime)
cts
  TargetFile FilePath
fp -> TargetId
-> Bool -> UnitId -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (FilePath -> Maybe Phase -> TargetId
GHC.TargetFile FilePath
fp Maybe Phase
forall a. Maybe a
Nothing) Bool
True UnitId
uid Maybe (InputFileBuffer, UTCTime)
cts

fromTargetId :: [FilePath]          -- ^ import paths
             -> [String]            -- ^ extensions to consider
             -> UnitId
             -> GHC.TargetId
             -> Maybe (InputFileBuffer, UTCTime)
             -> IO [TargetDetails]
-- For a target module we consider all the import paths
fromTargetId :: [FilePath]
-> [FilePath]
-> UnitId
-> TargetId
-> Maybe (InputFileBuffer, UTCTime)
-> IO [TargetDetails]
fromTargetId [FilePath]
is [FilePath]
exts UnitId
unitId (GHC.TargetModule ModuleName
modName) Maybe (InputFileBuffer, UTCTime)
ctts = do
    let fps :: [FilePath]
fps = [FilePath
i FilePath -> FilePath -> FilePath
</> ModuleName -> FilePath
moduleNameSlashes ModuleName
modName 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"]
              ]
    [TargetDetails] -> IO [TargetDetails]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Target
-> [FilePath]
-> UnitId
-> Maybe (InputFileBuffer, UTCTime)
-> TargetDetails
TargetDetails (ModuleName -> Target
TargetModule ModuleName
modName) [FilePath]
fps UnitId
unitId Maybe (InputFileBuffer, UTCTime)
ctts]
-- For a 'TargetFile' we consider all the possible module names
fromTargetId [FilePath]
_ [FilePath]
_ UnitId
unitId (GHC.TargetFile FilePath
f Maybe Phase
_) Maybe (InputFileBuffer, UTCTime)
ctts = do
    let other :: FilePath
other
          | FilePath
"-boot" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` FilePath
f = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
dropEnd Int
5 FilePath
f
          | Bool
otherwise = (FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-boot")
    [TargetDetails] -> IO [TargetDetails]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Target
-> [FilePath]
-> UnitId
-> Maybe (InputFileBuffer, UTCTime)
-> TargetDetails
TargetDetails (FilePath -> Target
TargetFile FilePath
f) [FilePath
f, FilePath
other] UnitId
unitId Maybe (InputFileBuffer, UTCTime)
ctts]

{-
Note [ Ambiguous Package Qualified Imports Workaround ]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Source level package qualified imports `import "foo" A` interpret "foo" as a package name.

When one manually builds a `RawPkgQual` for an `ImportDecl` one can get away with using a unit-id, but only for external (i.e. not home) units.
That it works does not seem entirely intended (see quoted snippet below), the code is in `renamePkgQual`: If a package qualifier is not found among packages it's looked up as an external unit. This is already in the code path for `OtherPkg` though, which is why Home Units are excluded.
```
    | otherwise
    -> OtherPkg (UnitId pkg_fs)
       -- not really correct as pkg_fs is unlikely to be a valid unit-id but
       -- we will report the failure later...
```

Home units will only be found if the qualifier matches their dflags' `thisPackageName`. However that's bugged because the lookup doesn't bother considering there can be multiple units in the same package (library, sublibraries and exe units), and just picks the first found, leading to an import error if e.g. the library unit is picked but the module was in the exe one.
Related GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/24227

Turns out that the package name of a home unit is pretty meaningless though, so we can update the dflags to replace it with anything that's actually unique so we can dodge the bug.

Another stumbling block is that the `IIDecl` mode of an `InteractiveImport` does not allow importing hidden modules, but again for home units we can alter the DynFlags so all modules are exposed.

See issue #288 for what can we do for users at the repl.
-}

-- ----------------------------------------------------------------------------
-- GHC Utils that should likely be exposed by GHC
-- ----------------------------------------------------------------------------

mkSimpleTarget :: DynFlags -> FilePath -> GHC.Target
mkSimpleTarget :: DynFlags -> FilePath -> Target
mkSimpleTarget DynFlags
df FilePath
fp = TargetId
-> Bool -> UnitId -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (FilePath -> Maybe Phase -> TargetId
GHC.TargetFile FilePath
fp Maybe Phase
forall a. Maybe a
Nothing) Bool
True (DynFlags -> UnitId
homeUnitId_ DynFlags
df) Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing

hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv
hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv
hscSetUnitEnv UnitEnv
ue HscEnv
env = HscEnv
env { hsc_unit_env = ue }

home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags
home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags
home_unit_dflags HscEnv
hsc_env UnitId
uid
  = (HomeUnitEnv -> DynFlags) -> Maybe HomeUnitEnv -> Maybe DynFlags
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HomeUnitEnv -> DynFlags
homeUnitEnv_dflags
  (Maybe HomeUnitEnv -> Maybe DynFlags)
-> (HscEnv -> Maybe HomeUnitEnv) -> HscEnv -> Maybe DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
HUG.lookupHugUnitId UnitId
uid (HomeUnitGraph -> Maybe HomeUnitEnv)
-> (HscEnv -> HomeUnitGraph) -> HscEnv -> Maybe HomeUnitEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitEnv -> HomeUnitGraph
ue_home_unit_graph
  (UnitEnv -> HomeUnitGraph)
-> (HscEnv -> UnitEnv) -> HscEnv -> HomeUnitGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env
  (HscEnv -> Maybe DynFlags) -> HscEnv -> Maybe DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env

-- | See Note [Package Qualified Imports] for why this is sometimes a @PackageName@ and sometimes a @UnitId@.
newtype PackageQualifier = PackageQualifier FastString

lookupUnitPackageQualifier :: HscEnv -> UnitId -> Maybe PackageQualifier
lookupUnitPackageQualifier :: HscEnv -> UnitId -> Maybe PackageQualifier
lookupUnitPackageQualifier HscEnv
env UnitId
uid = Maybe PackageQualifier
home_unit_name Maybe PackageQualifier
-> Maybe PackageQualifier -> Maybe PackageQualifier
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PackageQualifier
ext_unit_name
          where
            -- See Note [Package Qualified Imports]
            home_unit_name :: Maybe PackageQualifier
home_unit_name = FastString -> PackageQualifier
PackageQualifier (FastString -> PackageQualifier)
-> (FilePath -> FastString) -> FilePath -> PackageQualifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FastString
mkFastString (FilePath -> PackageQualifier)
-> Maybe FilePath -> Maybe PackageQualifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DynFlags -> Maybe FilePath
thisPackageName (DynFlags -> Maybe FilePath) -> Maybe DynFlags -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HscEnv -> UnitId -> Maybe DynFlags
home_unit_dflags HscEnv
env UnitId
uid)
            ext_unit_name :: Maybe PackageQualifier
ext_unit_name = PackageQualifier -> UnitInfo -> PackageQualifier
forall a b. a -> b -> a
const (FastString -> PackageQualifier
PackageQualifier (UnitId -> FastString
unitIdFS UnitId
uid)) (UnitInfo -> PackageQualifier)
-> Maybe UnitInfo -> Maybe PackageQualifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
env) UnitId
uid

packageImportDecl :: PackageQualifier -> ModuleName -> ImportDecl GhcPs
packageImportDecl :: PackageQualifier -> ModuleName -> ImportDecl GhcPs
packageImportDecl (PackageQualifier FastString
pkgName) ModuleName
mn =
  (ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl (ModuleName -> ImportDecl GhcPs) -> ModuleName -> ImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ModuleName
mn)
    { ideclPkgQual = RawPkgQual
#if MIN_VERSION_ghc(10,1,0)
        NoSourceText pkgName
#else
        StringLiteral
          { sl_st = NoSourceText
          , sl_fs = pkgName
          , sl_tc = Nothing
          }
#endif
    }
-- ----------------------------------------------------------------------------
-- Session cache directory
-- ----------------------------------------------------------------------------

data CacheDirs = CacheDirs
  { CacheDirs -> FilePath
hiCacheDir :: FilePath
  , CacheDirs -> FilePath
byteCodeCacheDir :: FilePath
  , CacheDirs -> FilePath
hieCacheDir :: FilePath
  , CacheDirs -> FilePath
objCacheDir :: FilePath
  }

getCacheDirs :: String -> [String] -> IO CacheDirs
getCacheDirs :: FilePath -> [FilePath] -> IO CacheDirs
getCacheDirs FilePath
prefix [FilePath]
opts = do
  mCacheDir <- FilePath -> IO (Maybe FilePath)
Env.lookupEnv FilePath
"HDB_CACHE_DIR"
  rootDir <- case mCacheDir of
    Just FilePath
dir -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
dir
    Maybe FilePath
Nothing ->
      XdgDirectory -> FilePath -> IO FilePath
Directory.getXdgDirectory XdgDirectory
Directory.XdgCache FilePath
"hdb"
  let sessionCacheDir = FilePath
rootDir 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
  Directory.createDirectoryIfMissing True sessionCacheDir
  pure CacheDirs
    { hiCacheDir = sessionCacheDir
    , byteCodeCacheDir = sessionCacheDir
    , hieCacheDir = sessionCacheDir
    , objCacheDir = sessionCacheDir
    }
  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)


getTargetFileSummary ::
  HscEnv ->
  GHC.Target ->
  IO (Either GHC.DriverMessages GHC.ModSummary)
getTargetFileSummary :: HscEnv -> Target -> IO (Either DriverMessages ModSummary)
getTargetFileSummary HscEnv
hsc_env Target
target
  | GHC.TargetFile FilePath
file Maybe Phase
mb_phase <- TargetId
targetId
  = do
    let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
GHC.augmentByWorkingDirectory DynFlags
dflags FilePath
file
    exists <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
#if MIN_VERSION_ghc(10,1,0)
    -- summariseFile now takes a mutable ModSummary cache (an IORef).
    old_summary_map <- newIORef Map.empty
#endif
    if exists || isJust maybe_buf
    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
         maybe_buf
    else
      return $ Left $ GHC.singleMessage $
      GHC.mkPlainErrorMsgEnvelope noSrcSpan (GHC.DriverFileNotFound offset_file)
  | Bool
otherwise = FilePath -> IO (Either DriverMessages ModSummary)
forall a. HasCallStack => FilePath -> a
error FilePath
"FIXME"
  where
#if !MIN_VERSION_ghc(10,1,0)
      old_summary_map :: Map k a
old_summary_map = Map k a
forall {k} {a}. Map k a
Map.empty
#endif
      GHC.Target {TargetId
targetId :: Target -> TargetId
targetId :: TargetId
targetId, targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid} = Target
target
      home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
      dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))

compileModuleWithDepsInHpt ::
  GHC.Target ->
  Ghc (Maybe SourceError)
compileModuleWithDepsInHpt :: Target -> Ghc (Maybe SourceError)
compileModuleWithDepsInHpt target :: Target
target@GHC.Target{targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid} = do
  hsc_env0 <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let !old_active = HscEnv -> UnitId
hscActiveUnitId HscEnv
hsc_env0
  let !hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
uid HscEnv
hsc_env0
  ehmi <- liftIO $ try @SourceError $ do
    Right summary <- getTargetFileSummary hsc_env target
    result <- compileOne hsc_env (forceRecomp summary) 1 1 Nothing (GHC.HomeModLinkable Nothing Nothing)
    cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (ms_hspp_opts summary)
    pure result
  case ehmi of
   Left SourceError
e -> do
     Maybe SourceError -> Ghc (Maybe SourceError)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceError -> Ghc (Maybe SourceError))
-> Maybe SourceError -> Ghc (Maybe SourceError)
forall a b. (a -> b) -> a -> b
$ SourceError -> Maybe SourceError
forall a. a -> Maybe a
Just SourceError
e
   Right HomeModInfo
hmi -> do
    HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> Ghc ()) -> (HscEnv -> HscEnv) -> HscEnv -> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
old_active (HscEnv -> Ghc ()) -> Ghc HscEnv -> Ghc ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO HscEnv -> Ghc HscEnv
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([HomeModInfo] -> HscEnv -> IO HscEnv
addDepsToHscEnv [HomeModInfo
hmi] HscEnv
hsc_env)
    Maybe SourceError -> Ghc (Maybe SourceError)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SourceError
forall a. Maybe a
Nothing
  where
    -- This bypasses another recompilation check in 'compileOne'
    forceRecomp :: ModSummary -> ModSummary
forceRecomp ModSummary
summary =
      ModSummary
summary {ms_hspp_opts = gopt_set (ms_hspp_opts summary) Opt_ForceRecomp}

addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> IO HscEnv
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> IO HscEnv
addDepsToHscEnv [HomeModInfo]
deps HscEnv
hsc_env = do
  [HomeModInfo] -> (HomeModInfo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [HomeModInfo]
deps ((HomeModInfo -> IO ()) -> IO ())
-> (HomeModInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ HomeModInfo
dep -> HomeModInfo -> HscEnv -> IO ()
hscInsertHPT HomeModInfo
dep HscEnv
hsc_env
  HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnv
hsc_env

cleanCurrentModuleTempFilesMaybe :: MonadIO m => GHC.Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags
    then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Logger -> TmpFs -> IO ()
Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
    else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs

-- ----------------------------------------------------------------------------
-- The Interactive DynFlags
-- ----------------------------------------------------------------------------

interactiveGhcDebuggerUnit :: Unit
interactiveGhcDebuggerUnit :: Unit
interactiveGhcDebuggerUnit = FilePath -> Unit
stringToUnit FilePath
"interactiveGhcDebugger"

interactiveGhcDebuggerUnitId :: UnitId
interactiveGhcDebuggerUnitId :: UnitId
interactiveGhcDebuggerUnitId = Unit -> UnitId
toUnitId Unit
interactiveGhcDebuggerUnit

getInteractiveDebuggerDynFlags :: GhcMonad m => m DynFlags
getInteractiveDebuggerDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDebuggerDynFlags = do
  env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  pure $ ue_unitFlags interactiveGhcDebuggerUnitId (hsc_unit_env env)

-- | Set the interactive 'DynFlags' for the haskell-debugger session.
-- We manage a separate home unit for the interactive 'DynFlags'.
-- The invariant is that 'DynFlags' found in 'InteractiveContext' *must* be
-- the same 'DynFlags' as the ones found in 'interactiveGhcDebuggerUnitId' in
-- the 'HomeUnitEnv'
-- This function upholds this invariant.
--
-- Always prefer this, over 'setInteractiveDynFlags'.
setInteractiveDebuggerDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDebuggerDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDebuggerDynFlags DynFlags
dflags = do
  env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  norm_dflags <- GHC.normaliseInteractiveDynFlags (hsc_logger env) dflags
  env' <- GHC.initialiseInteractiveDynFlags norm_dflags env
  -- Make sure the 'InteractiveContext' and 'interactiveGhcDebuggerUnitId' have exactly
  -- the same 'DynFlags'
  let newEnv =
        if DynFlags -> UnitId
homeUnitId_ (HscEnv -> DynFlags
hsc_dflags HscEnv
env') UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
interactiveGhcDebuggerUnitId
          then HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
norm_dflags HscEnv
env'
          else
            let
              unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
env'
            in HscEnv
env'
                { hsc_unit_env = unit_env
                    { ue_home_unit_graph =
                        updateUnitFlags
                          interactiveGhcDebuggerUnitId
                          (const norm_dflags)
                          (ue_home_unit_graph unit_env)
                    }
                }
  setSession newEnv

-- ----------------------------------------------------------------------------
-- Modification of DynFlags
-- ----------------------------------------------------------------------------

setWorkingDirectory :: FilePath -> DynFlags -> DynFlags
setWorkingDirectory :: FilePath -> DynFlags -> DynFlags
setWorkingDirectory FilePath
p DynFlags
d = DynFlags
d { workingDirectory =  Just p }

setCacheDirs :: CacheDirs -> DynFlags -> DynFlags
setCacheDirs :: CacheDirs -> DynFlags -> DynFlags
setCacheDirs CacheDirs{FilePath
hiCacheDir :: CacheDirs -> FilePath
byteCodeCacheDir :: CacheDirs -> FilePath
hieCacheDir :: CacheDirs -> FilePath
objCacheDir :: CacheDirs -> FilePath
hiCacheDir :: FilePath
byteCodeCacheDir :: FilePath
hieCacheDir :: FilePath
objCacheDir :: FilePath
..} DynFlags
flags = DynFlags
flags
  { hiDir = Just hiCacheDir
  , hieDir = Just hieCacheDir
  , objectDir = Just objCacheDir
#if MIN_VERSION_ghc(9,14,2)
  , bytecodeDir = Just byteCodeCacheDir
#endif
  }

-- | Prefixes output directories (i.e. @hiDir@, @hieDir@, @stubDir@, @dumpDir@) with @rootDir@ argument.
makeDynFlagsDirsAbsolute :: FilePath -> DynFlags -> DynFlags
makeDynFlagsDirsAbsolute :: FilePath -> DynFlags -> DynFlags
makeDynFlagsDirsAbsolute FilePath
rootDir DynFlags
df0 =
  (DynFlags
 -> ((Maybe FilePath -> Maybe FilePath) -> DynFlags -> DynFlags)
 -> DynFlags)
-> DynFlags
-> [(Maybe FilePath -> Maybe FilePath) -> DynFlags -> DynFlags]
-> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ DynFlags
df (Maybe FilePath -> Maybe FilePath) -> DynFlags -> DynFlags
f -> (Maybe FilePath -> Maybe FilePath) -> DynFlags -> DynFlags
f ((FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath)
-> (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
rootDir FilePath -> FilePath -> FilePath
</>)) DynFlags
df) DynFlags
df0
    [(\ Maybe FilePath -> Maybe FilePath
f DynFlags
df -> DynFlags
df {hiDir = f (hiDir df)})
    ,(\ Maybe FilePath -> Maybe FilePath
f DynFlags
df -> DynFlags
df {hieDir = f (hieDir df)})
    ,(\ Maybe FilePath -> Maybe FilePath
f DynFlags
df -> DynFlags
df {stubDir = f (stubDir df)})
    ,(\ Maybe FilePath -> Maybe FilePath
f DynFlags
df -> DynFlags
df {dumpDir = f (dumpDir df)})]

makeDynFlagsAbsoluteOverall :: FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsoluteOverall :: FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsoluteOverall FilePath
rootDir DynFlags
df0 = FilePath -> DynFlags -> DynFlags
makeDynFlagsDirsAbsolute FilePath
rootDir (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute FilePath
rootDir DynFlags
df0

-- | If the compiler supports `.gbc` files (>= 9.14.2), then persist these
-- artefacts to disk.
enableByteCodeGeneration :: DynFlags -> DynFlags
enableByteCodeGeneration :: DynFlags -> DynFlags
enableByteCodeGeneration DynFlags
dflags =
#if MIN_VERSION_ghc(9,14,2)
  dflags
    & flip gopt_unset Opt_ByteCodeAndObjectCode
    & flip gopt_set Opt_ByteCode
    & flip gopt_set Opt_WriteByteCode
    & flip gopt_set Opt_WriteInterface
#else
  DynFlags
dflags
#endif

setBytecodeBackend :: DynFlags -> DynFlags
setBytecodeBackend :: DynFlags -> DynFlags
setBytecodeBackend DynFlags
dflags = DynFlags
dflags
  {
#if MIN_VERSION_ghc(9,14,2)
  backend = GHC.bytecodeBackend
#else
  backend = GHC.interpreterBackend
#endif
  }

-- | Enable the external interpreter by default unless the user sets
-- @preferInternalInterpreter=True@ (with @--internal-interpreter@)
enableExternalInterpreter :: Bool -> DynFlags -> DynFlags
enableExternalInterpreter :: Bool -> DynFlags -> DynFlags
enableExternalInterpreter Bool
preferInternalInterpreter DynFlags
dflags
  | Bool
preferInternalInterpreter
  = DynFlags
dflags DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_unset` GeneralFlag
GHC.Opt_ExternalInterpreter
  | Bool
otherwise
  = DynFlags
dflags DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_ExternalInterpreter

-- | Force -dynamic on the debuggee if the debugger (which is also the external
-- interpreter) was compiled with -dynamic. On Windows the debugger can't be
-- built dynamic, so we won't enable it there.
--
-- See Note [Dynamic Debuggee for dynamic debugger]
enableDynamicDebuggee :: DynFlags -> DynFlags
enableDynamicDebuggee :: DynFlags -> DynFlags
enableDynamicDebuggee DynFlags
dflags
  | Bool
hostIsDynamic
  = Way -> DynFlags -> DynFlags
addWay' Way
WayDyn DynFlags
dflags
  | Bool
otherwise
  = DynFlags
dflags

setPgmI, addOptI :: String -> DynFlags -> DynFlags
setPgmI :: FilePath -> DynFlags -> DynFlags
setPgmI FilePath
f = (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ((ToolSettings -> ToolSettings) -> DynFlags -> DynFlags)
-> (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ \ToolSettings
s -> ToolSettings
s { toolSettings_pgm_i = f }
addOptI :: FilePath -> DynFlags -> DynFlags
addOptI FilePath
f = (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ((ToolSettings -> ToolSettings) -> DynFlags -> DynFlags)
-> (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ \ToolSettings
s -> ToolSettings
s { toolSettings_opt_i = f : toolSettings_opt_i s }

getPgmI :: DynFlags -> String
getPgmI :: DynFlags -> FilePath
getPgmI DynFlags
df = ToolSettings -> FilePath
toolSettings_pgm_i (DynFlags -> ToolSettings
toolSettings DynFlags
df)

alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ToolSettings -> ToolSettings
f DynFlags
dynFlags = DynFlags
dynFlags { toolSettings = f (toolSettings dynFlags) }

setDynFlagWays :: Ways -> DynFlags -> DynFlags
setDynFlagWays :: Ways -> DynFlags -> DynFlags
setDynFlagWays Ways
ws DynFlags
dyn = (Way -> DynFlags -> DynFlags) -> DynFlags -> Ways -> DynFlags
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Way -> DynFlags -> DynFlags
addWay' DynFlags
dyn Ways
ws

addWay' :: Way -> DynFlags -> DynFlags
addWay' :: Way -> DynFlags -> DynFlags
addWay' Way
w DynFlags
dflags0 =
   let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags0
       dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }
       dflags2 :: DynFlags
dflags2 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
GHC.setGeneralFlag' DynFlags
dflags1
                       (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform Way
w)
       dflags3 :: DynFlags
dflags3 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
GHC.unSetGeneralFlag' DynFlags
dflags2
                       (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform Way
w)
   in DynFlags
dflags3

-- | See Note [ UniqSupply is process global ]
initUniqSupplyIO :: IO ()
initUniqSupplyIO :: IO ()
initUniqSupplyIO = Word64 -> Int -> IO ()
GHC.initUniqSupply Word64
0 Int
1

-- ----------------------------------------------------------------------------
-- Wrappers around GHC's odd behavior
-- ----------------------------------------------------------------------------

resumeExec :: GhcMonad m => SingleStep -> Maybe Int -> m ExecResult
resumeExec :: forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
resumeExec SingleStep
a Maybe Int
b = do
  -- IC's ic_imports field is not kept in sync with ic_gre_cache, so we could do
  -- this call later, but why rely on that.
  imports <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
GHC.getContext

  v <- GHC.resumeExec a b

  -- To have interactive imports persist after a `continue` command we have to
  -- work around how GHC.resumeExec handles the InteractiveContext (IC).
  --
  -- GHC.resumeExec resets the scope of the IC (i.e. ic_gre_cache) to what it
  -- was before the last ExecBreak.
  --
  -- It makes sense for GHC.resumeExec to remove from the IC scope the
  -- breakpoint locals and anything that could have been defined with them, in
  -- fact they are also unloaded.
  --
  -- The way it's done though also rollbacks any import statements that were
  -- executed since the last ExecBreak. The only fix is to reimport everything
  -- again.
  --
  -- Note: GHC.setContext recomputes the scope of the interactive imports from
  -- scratch everytime. Considering `runDebugger` adds the whole home unit to
  -- the interactive imports this might become a bottleneck. GHC does not keep
  -- any reference to the scope containing just the imports, so we would have to
  -- cache it ourselves (and then extend it with the cached scope of
  -- ic_tythings, i.e. igre_prompt_env (c.f. replaceImportEnv)).
  GHC.setContext imports
  pure v

-- ----------------------------------------------------------------------------
-- Utils that we need, but don't want to incur an additional dependency for.
-- ----------------------------------------------------------------------------

-- | Drop a number of elements from the end of the list.
--
-- > dropEnd 3 "hello"  == "he"
-- > dropEnd 5 "bye"    == ""
-- > dropEnd (-1) "bye" == "bye"
-- > \i xs -> dropEnd i xs `isPrefixOf` xs
-- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)
-- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]
dropEnd :: Int -> [a] -> [a]
dropEnd :: forall a. Int -> [a] -> [a]
dropEnd Int
i [a]
xs
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [a]
xs
    | Bool
otherwise = [a] -> [a] -> [a]
forall {a} {a}. [a] -> [a] -> [a]
f [a]
xs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs)
    where f :: [a] -> [a] -> [a]
f (a
a:[a]
as) (a
_:[a]
bs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
f [a]
as [a]
bs
          f [a]
_ [a]
_ = []

#if !MIN_VERSION_ghc(10,1,0)
deriving instance Ord PkgDbRef
deriving instance Ord PackageDBFlag
#endif