{-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-}

-- | 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,
  TargetDetails(..),
  Target(..),
  toGhcTarget,
  CacheDirs(..),
  getCacheDirs,
  -- * Debugger's Interactive Home Unit
  interactiveGhcDebuggerUnitId,
  getInteractiveDebuggerDynFlags,
  setInteractiveDebuggerDynFlags,
  -- * DynFlags modifications
  setWorkingDirectory,
  setCacheDirs,
  setBytecodeBackend,
  enableByteCodeGeneration,
  )
  where

import Control.Monad
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 Data.Function
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.List as L
import qualified Data.Containers.ListUtils as L
import GHC.ResponseFile (expandResponse)
import HIE.Bios.Environment as HIE
import System.FilePath
import qualified System.Directory as Directory
import qualified System.Environment as Env

import qualified GHC
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
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

-- | 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
        let special_target = DynFlags -> FilePath -> Target
mkSimpleTarget DynFlags
df FilePath
abs_fp
        pure $ (df, special_target : 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 targets = FilePath -> [Target] -> [Target]
HIE.makeTargetsAbsolute FilePath
root [Target]
targets'
            root = case DynFlags -> Maybe FilePath
workingDirectory DynFlags
dflags' of
              Maybe FilePath
Nothing   -> FilePath
compRoot
              Just FilePath
wdir -> FilePath
compRoot FilePath -> FilePath -> FilePath
</> FilePath
wdir
        cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts
        let dflags'' =
              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.
createUnitEnvFromFlags :: DynFlags -> [DynFlags] -> IO HomeUnitGraph
createUnitEnvFromFlags :: DynFlags -> [DynFlags] -> IO HomeUnitGraph
createUnitEnvFromFlags DynFlags
initialDynFlags [DynFlags]
unitDflags = do
  let
    newInternalUnitEnv :: DynFlags -> HomePackageTable -> HomeUnitEnv
newInternalUnitEnv DynFlags
dflags HomePackageTable
hpt = UnitState
-> Maybe [UnitDatabase UnitEnvGraphKey]
-> DynFlags
-> HomePackageTable
-> Maybe HomeUnit
-> HomeUnitEnv
mkHomeUnitEnv UnitState
State.emptyUnitState Maybe [UnitDatabase UnitEnvGraphKey]
forall a. Maybe a
Nothing DynFlags
dflags HomePackageTable
hpt Maybe HomeUnit
forall a. Maybe a
Nothing

  unitEnvList <- (DynFlags -> IO (UnitEnvGraphKey, HomeUnitEnv))
-> [DynFlags] -> IO [(UnitEnvGraphKey, 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
dflags -> do
    emptyHpt <- IO HomePackageTable
emptyHomePackageTable
    pure (homeUnitId_ dflags, newInternalUnitEnv dflags emptyHpt)) [DynFlags]
unitDflags

  interactiveHomeUnit <- do
    let interactiveDynFlags = DynFlags
initialDynFlags
          { homeUnitId_ = interactiveGhcDebuggerUnitId
          , importPaths = []
          , packageFlags =
              [ ExposePackage
                  ("-package-id " ++ unitIdString unitId)
                  (UnitIdArg $ RealUnit (Definite unitId))
                  (ModRenaming True [])
              | (unitId, _) <- unitEnvList
              ]
          }
    emptyHpt <- emptyHomePackageTable
    pure (homeUnitId_ interactiveDynFlags, newInternalUnitEnv interactiveDynFlags emptyHpt)

  pure $ unitEnv_new (Map.fromList (interactiveHomeUnit : unitEnvList))

-- | 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
  let dflags0 :: DynFlags
dflags0         = HscEnv -> DynFlags
hsc_dflags HscEnv
env
  -- additionally, set checked dflags so we don't lose fixes
  initial_home_graph <- DynFlags -> [DynFlags] -> IO HomeUnitGraph
createUnitEnvFromFlags DynFlags
dflags0 [DynFlags]
unitDflags
  let home_units = HomeUnitGraph -> Set UnitEnvGraphKey
forall v. UnitEnvGraph v -> Set UnitEnvGraphKey
unitEnv_keys HomeUnitGraph
initial_home_graph
  home_unit_graph <- forM initial_home_graph $ \HomeUnitEnv
homeUnitEnv -> do
    let cached_unit_dbs :: Maybe [UnitDatabase UnitEnvGraphKey]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitEnvGraphKey]
homeUnitEnv_unit_dbs HomeUnitEnv
homeUnitEnv
        dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
        old_hpt :: HomePackageTable
old_hpt = HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
homeUnitEnv

    (dbs,unit_state,home_unit,mconstants) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitEnvGraphKey]
-> Set UnitEnvGraphKey
-> IO
     ([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
      Maybe PlatformConstants)
State.initUnits (HscEnv -> Logger
hsc_logger HscEnv
env) DynFlags
dflags Maybe [UnitDatabase UnitEnvGraphKey]
cached_unit_dbs Set UnitEnvGraphKey
home_units

    updated_dflags <- GHC.updatePlatformConstants dflags mconstants
    pure HomeUnitEnv
      { homeUnitEnv_units = unit_state
      , homeUnitEnv_unit_dbs = Just dbs
      , homeUnitEnv_dflags = updated_dflags
      , homeUnitEnv_hpt = old_hpt
      , homeUnitEnv_home_unit = Just home_unit
      }

  let dflags1 = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitEnvGraphKey -> HomeUnitGraph -> HomeUnitEnv
forall v. UnitEnvGraphKey -> UnitEnvGraph v -> v
unitEnv_lookup UnitEnvGraphKey
interactiveGhcDebuggerUnitId HomeUnitGraph
home_unit_graph
  let unit_env = UnitEnv
        { ue_platform :: Platform
ue_platform        = DynFlags -> Platform
targetPlatform DynFlags
dflags1
        , ue_namever :: GhcNameVersion
ue_namever         = DynFlags -> GhcNameVersion
GHC.ghcNameVersion DynFlags
dflags1
        , ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph = HomeUnitGraph
home_unit_graph
        , ue_current_unit :: UnitEnvGraphKey
ue_current_unit    = UnitEnvGraphKey
interactiveGhcDebuggerUnitId
        , ue_module_graph :: ModuleGraph
ue_module_graph    = UnitEnv -> ModuleGraph
ue_module_graph (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env)
        , ue_eps :: ExternalUnitCache
ue_eps             = UnitEnv -> ExternalUnitCache
ue_eps (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env)
        }
  pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env


-- | 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 = 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] -> UnitEnvGraphKey -> TargetId -> IO [TargetDetails]
fromTargetId (DynFlags -> [FilePath]
importPaths DynFlags
df) [FilePath]
exts (DynFlags -> UnitEnvGraphKey
homeUnitId_ DynFlags
df) (Target -> TargetId
GHC.targetId 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 (L.nubOrdOn targetTarget ctargets)
    pure (hscEnv', concat ts)

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 -> UnitEnvGraphKey
targetUnitId :: UnitId
  -- ^ UnitId of 'targetTarget'.
  }
  deriving (TargetDetails -> TargetDetails -> Bool
(TargetDetails -> TargetDetails -> Bool)
-> (TargetDetails -> TargetDetails -> Bool) -> Eq TargetDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetDetails -> TargetDetails -> Bool
== :: TargetDetails -> TargetDetails -> Bool
$c/= :: TargetDetails -> TargetDetails -> Bool
/= :: TargetDetails -> TargetDetails -> Bool
Eq, Eq TargetDetails
Eq TargetDetails =>
(TargetDetails -> TargetDetails -> Ordering)
-> (TargetDetails -> TargetDetails -> Bool)
-> (TargetDetails -> TargetDetails -> Bool)
-> (TargetDetails -> TargetDetails -> Bool)
-> (TargetDetails -> TargetDetails -> Bool)
-> (TargetDetails -> TargetDetails -> TargetDetails)
-> (TargetDetails -> TargetDetails -> TargetDetails)
-> Ord TargetDetails
TargetDetails -> TargetDetails -> Bool
TargetDetails -> TargetDetails -> Ordering
TargetDetails -> TargetDetails -> TargetDetails
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 :: TargetDetails -> TargetDetails -> Ordering
compare :: TargetDetails -> TargetDetails -> Ordering
$c< :: TargetDetails -> TargetDetails -> Bool
< :: TargetDetails -> TargetDetails -> Bool
$c<= :: TargetDetails -> TargetDetails -> Bool
<= :: TargetDetails -> TargetDetails -> Bool
$c> :: TargetDetails -> TargetDetails -> Bool
> :: TargetDetails -> TargetDetails -> Bool
$c>= :: TargetDetails -> TargetDetails -> Bool
>= :: TargetDetails -> TargetDetails -> Bool
$cmax :: TargetDetails -> TargetDetails -> TargetDetails
max :: TargetDetails -> TargetDetails -> TargetDetails
$cmin :: TargetDetails -> TargetDetails -> TargetDetails
min :: TargetDetails -> TargetDetails -> TargetDetails
Ord)

-- | 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]
_ UnitEnvGraphKey
uid) = case Target
tid of
  TargetModule ModuleName
modl -> TargetId
-> Bool
-> UnitEnvGraphKey
-> Maybe (InputFileBuffer, UTCTime)
-> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
modl) Bool
True UnitEnvGraphKey
uid Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
  TargetFile FilePath
fp -> TargetId
-> Bool
-> UnitEnvGraphKey
-> Maybe (InputFileBuffer, UTCTime)
-> Target
GHC.Target (FilePath -> Maybe Phase -> TargetId
GHC.TargetFile FilePath
fp Maybe Phase
forall a. Maybe a
Nothing) Bool
True UnitEnvGraphKey
uid Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing

fromTargetId :: [FilePath]          -- ^ import paths
             -> [String]            -- ^ extensions to consider
             -> UnitId
             -> GHC.TargetId
             -> IO [TargetDetails]
-- For a target module we consider all the import paths
fromTargetId :: [FilePath]
-> [FilePath] -> UnitEnvGraphKey -> TargetId -> IO [TargetDetails]
fromTargetId [FilePath]
is [FilePath]
exts UnitEnvGraphKey
unitId (GHC.TargetModule ModuleName
modName) = 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] -> UnitEnvGraphKey -> TargetDetails
TargetDetails (ModuleName -> Target
TargetModule ModuleName
modName) [FilePath]
fps UnitEnvGraphKey
unitId]
-- For a 'TargetFile' we consider all the possible module names
fromTargetId [FilePath]
_ [FilePath]
_ UnitEnvGraphKey
unitId (GHC.TargetFile FilePath
f Maybe Phase
_) = 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] -> UnitEnvGraphKey -> TargetDetails
TargetDetails (FilePath -> Target
TargetFile FilePath
f) [FilePath
f, FilePath
other] UnitEnvGraphKey
unitId]

-- ----------------------------------------------------------------------------
-- 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
-> UnitEnvGraphKey
-> Maybe (InputFileBuffer, UTCTime)
-> Target
GHC.Target (FilePath -> Maybe Phase -> TargetId
GHC.TargetFile FilePath
fp Maybe Phase
forall a. Maybe a
Nothing) Bool
True (DynFlags -> UnitEnvGraphKey
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 }

-- ----------------------------------------------------------------------------
-- 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)

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

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

interactiveGhcDebuggerUnitId :: UnitId
interactiveGhcDebuggerUnitId :: UnitEnvGraphKey
interactiveGhcDebuggerUnitId = Unit -> UnitEnvGraphKey
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 -> UnitEnvGraphKey
homeUnitId_ (HscEnv -> DynFlags
hsc_dflags HscEnv
env') UnitEnvGraphKey -> UnitEnvGraphKey -> Bool
forall a. Eq a => a -> a -> Bool
== UnitEnvGraphKey
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
  }

-- | 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
  }

-- ----------------------------------------------------------------------------
-- 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]
_ = []