{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.Debugger.Session.Builtin
(
debuggerViewBuiltinMods
, debuggerViewInstancesMods
, debuggerViewClassModName, debuggerViewClassContents
, hsDebuggerViewInMemoryUnitId
, addInMemoryHsDebuggerViewUnit
, makeInMemoryTarget
, runInternal
, debuggerInternalUnitId
, addInMemoryDebuggerInternalUnit
, debuggerRuntimeInternalContents
, debuggerRuntimeInternalModName
, debuggerRuntimeInternalUnit
, debuggerRuntimeInternalModule
#if !MIN_VERSION_ghc(9,14,2)
, addInMemoryFFIInspectUnit
, hsDebuggerFFIInspectUnitId
, debuggerRuntimeFFIInspectModName, debuggerRuntimeFFIInspectContents
#endif
)
where
import Data.FileEmbed
import Data.Function
import Data.Time
#if !MIN_VERSION_ghc(10,1,0)
import Data.Maybe
import qualified Data.Foldable as Foldable
#endif
import GHC
import GHC.Unit
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Monad
import GHC.Data.StringBuffer
import qualified GHC.Unit.Home.Graph as HUG
import qualified GHC.Unit.Home.PackageTable as HPT
import qualified GHC.Unit.State as State
import GHC.Data.FastString (unpackFS)
import Data.Coerce
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.LanguageExtensions as LangExt
import GHC.Runtime.Context (InteractiveContext(..), emptyInteractiveContext)
import Control.Monad.Catch (finally)
debuggerViewBuiltinMods :: [(ModuleName, StringBuffer)]
debuggerViewBuiltinMods :: [(ModuleName, StringBuffer)]
debuggerViewBuiltinMods = (ModuleName
debuggerViewClassModName, StringBuffer
debuggerViewClassContents)(ModuleName, StringBuffer)
-> [(ModuleName, StringBuffer)] -> [(ModuleName, StringBuffer)]
forall a. a -> [a] -> [a]
:((ModuleName, StringBuffer, String) -> (ModuleName, StringBuffer))
-> [(ModuleName, StringBuffer, String)]
-> [(ModuleName, StringBuffer)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
a,StringBuffer
b,String
_) -> (ModuleName
a,StringBuffer
b)) [(ModuleName, StringBuffer, String)]
debuggerViewInstancesMods
debuggerViewInstancesMods :: [(ModuleName, StringBuffer, String )]
debuggerViewInstancesMods :: [(ModuleName, StringBuffer, String)]
debuggerViewInstancesMods =
[ ( ModuleName
debuggerViewContainersModName
, StringBuffer
debuggerViewContainersContents
, String
"containers"
)
, ( ModuleName
debuggerViewTextModName
, StringBuffer
debuggerViewTextContents
, String
"text"
)
, ( ModuleName
debuggerViewByteStringModName
, StringBuffer
debuggerViewByteStringContents
, String
"bytestring"
)
]
debuggerViewClassModName :: ModuleName
debuggerViewClassModName :: ModuleName
debuggerViewClassModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.View.Class"
debuggerViewContainersModName :: ModuleName
debuggerViewContainersModName :: ModuleName
debuggerViewContainersModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.View.Containers"
debuggerViewTextModName :: ModuleName
debuggerViewTextModName :: ModuleName
debuggerViewTextModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.View.Text"
debuggerViewByteStringModName :: ModuleName
debuggerViewByteStringModName :: ModuleName
debuggerViewByteStringModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.View.ByteString"
hsDebuggerViewInMemoryUnitId :: UnitId
hsDebuggerViewInMemoryUnitId :: UnitId
hsDebuggerViewInMemoryUnitId = Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ String -> Unit
stringToUnit String
"haskell-debugger-view-in-memory"
addInMemoryHsDebuggerViewUnit
:: GhcMonad m
=> [UnitId]
-> DynFlags
-> m ()
addInMemoryHsDebuggerViewUnit :: forall (m :: * -> *). GhcMonad m => [UnitId] -> DynFlags -> m ()
addInMemoryHsDebuggerViewUnit = UnitId -> PackageName -> [UnitId] -> DynFlags -> m ()
forall (m :: * -> *).
GhcMonad m =>
UnitId -> PackageName -> [UnitId] -> DynFlags -> m ()
addInMemoryUnit
UnitId
hsDebuggerViewInMemoryUnitId
(FastString -> PackageName
PackageName FastString
"haskell-debugger-view")
#if !MIN_VERSION_ghc(9,14,2)
hsDebuggerFFIInspectUnitId :: UnitId
hsDebuggerFFIInspectUnitId :: UnitId
hsDebuggerFFIInspectUnitId = String -> UnitId
stringToUnitId String
"haskell-debugger-ffi-inspect"
addInMemoryFFIInspectUnit :: GhcMonad m => [UnitId] -> DynFlags -> m UnitId
addInMemoryFFIInspectUnit :: forall (m :: * -> *).
GhcMonad m =>
[UnitId] -> DynFlags -> m UnitId
addInMemoryFFIInspectUnit [UnitId]
deps DynFlags
dflags = do
UnitId -> PackageName -> [UnitId] -> DynFlags -> m ()
forall (m :: * -> *).
GhcMonad m =>
UnitId -> PackageName -> [UnitId] -> DynFlags -> m ()
addInMemoryUnit
UnitId
hsDebuggerFFIInspectUnitId
(UnitId -> PackageName
forall a b. Coercible a b => a -> b
coerce UnitId
hsDebuggerFFIInspectUnitId)
[UnitId]
deps DynFlags
dflags
UnitId -> m UnitId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UnitId
hsDebuggerFFIInspectUnitId
#endif
runInternal :: GhcMonad m => m a -> m a
runInternal :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal m a
m = m a -> m a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withSavedSession (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$
HscEnv -> HscEnv
emptyIC (HscEnv -> HscEnv) -> (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
debuggerInternalUnitId
[InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [ImportDecl GhcPs -> InteractiveImport
IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> ImportDecl GhcPs -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl (ModuleName -> ImportDecl GhcPs) -> ModuleName -> ImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ String -> ModuleName
GHC.mkModuleName String
"Prelude"]
m a
m
where
withSavedSession :: m b -> m b
withSavedSession m b
act = do
s <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
act `finally` setSession s
emptyIC :: HscEnv -> HscEnv
emptyIC HscEnv
env = case HscEnv -> InteractiveContext
hsc_IC HscEnv
env of
InteractiveContext{Int
[TyThing]
[Resume]
[InteractiveImport]
Maybe String
(InstEnv, [FamInst])
Name
FixityEnv
DefaultEnv
DynFlags
IcGlobalRdrEnv
Plugins
ic_dflags :: DynFlags
ic_mod_index :: Int
ic_imports :: [InteractiveImport]
ic_tythings :: [TyThing]
ic_gre_cache :: IcGlobalRdrEnv
ic_instances :: (InstEnv, [FamInst])
ic_fix_env :: FixityEnv
ic_default :: DefaultEnv
ic_resume :: [Resume]
ic_monad :: Name
ic_int_print :: Name
ic_cwd :: Maybe String
ic_plugins :: Plugins
ic_plugins :: InteractiveContext -> Plugins
ic_cwd :: InteractiveContext -> Maybe String
ic_int_print :: InteractiveContext -> Name
ic_monad :: InteractiveContext -> Name
ic_resume :: InteractiveContext -> [Resume]
ic_default :: InteractiveContext -> DefaultEnv
ic_fix_env :: InteractiveContext -> FixityEnv
ic_instances :: InteractiveContext -> (InstEnv, [FamInst])
ic_gre_cache :: InteractiveContext -> IcGlobalRdrEnv
ic_tythings :: InteractiveContext -> [TyThing]
ic_imports :: InteractiveContext -> [InteractiveImport]
ic_mod_index :: InteractiveContext -> Int
ic_dflags :: InteractiveContext -> DynFlags
..} ->
HscEnv
env {hsc_IC = (emptyInteractiveContext ic_dflags)
{ ic_mod_index = ic_mod_index
, ic_int_print = ic_int_print
, ic_monad = ic_monad
}}
debuggerInternalUnitId :: UnitId
debuggerInternalUnitId :: UnitId
debuggerInternalUnitId = String -> UnitId
stringToUnitId String
"haskell-debugger-internal"
addInMemoryDebuggerInternalUnit :: (MonadFail m, GhcMonad m) => DynFlags -> m ()
addInMemoryDebuggerInternalUnit :: forall (m :: * -> *). (MonadFail m, GhcMonad m) => DynFlags -> m ()
addInMemoryDebuggerInternalUnit DynFlags
dflags = do
us <- HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState) -> m HscEnv -> m UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Just deps' <- pure $ mapM (lookupPackageName us . PackageName) ["ghc-heap","ghci"]
let deps = DynFlags -> UnitId
baseUnitId DynFlags
dflags
#if !MIN_VERSION_ghc(9,14,2)
UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: UnitId
hsDebuggerFFIInspectUnitId
#endif
UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: [UnitId]
deps'
addInMemoryUnit
debuggerInternalUnitId
(coerce debuggerInternalUnitId)
deps $
dflags
{
safeHaskell = GHC.Sf_None,
dumpFlags = EnumSet.empty
}
`xopt_unset` LangExt.RebindableSyntax
`gopt_set` Opt_ImplicitImportQualified
return ()
addInMemoryUnit :: GhcMonad m
=> UnitId
-> PackageName
-> [UnitId]
-> DynFlags
-> m ()
addInMemoryUnit :: forall (m :: * -> *).
GhcMonad m =>
UnitId -> PackageName -> [UnitId] -> DynFlags -> m ()
addInMemoryUnit UnitId
uid (PackageName FastString
pkgName) [UnitId]
base_uids DynFlags
initialDynFlags = do
let imhdv_dflags :: DynFlags
imhdv_dflags = DynFlags
initialDynFlags
{ homeUnitId_ = uid
, importPaths = []
, packageFlags =
[ ExposePackage
(unitIdString unitId)
(UnitIdArg $ RealUnit (Definite unitId))
(ModRenaming True [])
| unitId <- base_uids
, unitId /= rtsUnitId
, unitId /= ghcInternalUnitId
]
, thisPackageName = Just $ unpackFS pkgName
}
DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_HideAllPackages
DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_InsertBreakpoints
#if MIN_VERSION_ghc(9,14,2)
& flip gopt_unset Opt_WriteByteCode
& flip gopt_unset Opt_WriteInterface
#endif
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
#if MIN_VERSION_ghc(10,1,0)
(unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags (hscUIC hsc_env) $ HUG.allUnits $ hsc_HUG $ hsc_env
#else
let 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]
HUG.homeUnitEnv_unit_dbs ([HomeUnitEnv] -> [UnitDatabase UnitId])
-> [HomeUnitEnv] -> [UnitDatabase UnitId]
forall a b. (a -> b) -> a -> b
$ UnitEnvGraph HomeUnitEnv -> [HomeUnitEnv]
forall a. UnitEnvGraph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
(dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger hsc_env) imhdv_dflags (Just cached_unit_dbs) $ HUG.allUnits $ hsc_HUG $ hsc_env
#endif
updated_dflags <- liftIO $ updatePlatformConstants imhdv_dflags mconstants
emptyHpt <- liftIO HPT.emptyHomePackageTable
modifySession $ \HscEnv
env ->
HscEnv
env
HscEnv -> (HscEnv -> HscEnv) -> HscEnv
forall a b. a -> (a -> b) -> b
& (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (\UnitEnvGraph HomeUnitEnv
hug ->
let hdv_hue :: HomeUnitEnv
hdv_hue = HUG.HomeUnitEnv
{ homeUnitEnv_units :: UnitState
HUG.homeUnitEnv_units = UnitState
unit_state
#if !MIN_VERSION_ghc(10,1,0)
, homeUnitEnv_unit_dbs :: Maybe [UnitDatabase UnitId]
HUG.homeUnitEnv_unit_dbs = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
#endif
, homeUnitEnv_dflags :: DynFlags
HUG.homeUnitEnv_dflags = DynFlags
updated_dflags
, homeUnitEnv_hpt :: HomePackageTable
HUG.homeUnitEnv_hpt = HomePackageTable
emptyHpt
, homeUnitEnv_home_unit :: Maybe HomeUnit
HUG.homeUnitEnv_home_unit = HomeUnit -> Maybe HomeUnit
forall a. a -> Maybe a
Just HomeUnit
home_unit
}
in UnitId
-> HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
forall v. UnitId -> v -> UnitEnvGraph v -> UnitEnvGraph v
HUG.unitEnv_insert UnitId
uid HomeUnitEnv
hdv_hue UnitEnvGraph HomeUnitEnv
hug
)
makeInMemoryTarget :: UnitId -> ModuleName -> StringBuffer -> IO GHC.Target
makeInMemoryTarget :: UnitId -> ModuleName -> StringBuffer -> IO Target
makeInMemoryTarget UnitId
uid ModuleName
modName StringBuffer
sb = do
time <- IO UTCTime
getCurrentTime
let mkTarget ModuleName
mn StringBuffer
contents = GHC.Target
{ targetId :: TargetId
targetId = String -> Maybe Phase -> TargetId
GHC.TargetFile (String
"in-memory:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mn) Maybe Phase
forall a. Maybe a
Nothing
, targetAllowObjCode :: Bool
targetAllowObjCode = Bool
False
, targetUnitId :: UnitId
GHC.targetUnitId = UnitId
uid
, targetContents :: Maybe (StringBuffer, UTCTime)
GHC.targetContents = (StringBuffer, UTCTime) -> Maybe (StringBuffer, UTCTime)
forall a. a -> Maybe a
Just (StringBuffer
contents, UTCTime
time)
}
return $ mkTarget modName sb
debuggerViewClassContents :: StringBuffer
debuggerViewClassContents :: StringBuffer
debuggerViewClassContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger-view/src/GHC/Debugger/View/Class.hs")
debuggerViewContainersContents :: StringBuffer
debuggerViewContainersContents :: StringBuffer
debuggerViewContainersContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger-view/src/GHC/Debugger/View/Containers.hs")
debuggerViewTextContents :: StringBuffer
debuggerViewTextContents :: StringBuffer
debuggerViewTextContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger-view/src/GHC/Debugger/View/Text.hs")
debuggerViewByteStringContents :: StringBuffer
debuggerViewByteStringContents :: StringBuffer
debuggerViewByteStringContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs")
#if !MIN_VERSION_ghc(9,14,2)
debuggerRuntimeFFIInspectModName :: ModuleName
debuggerRuntimeFFIInspectModName :: ModuleName
debuggerRuntimeFFIInspectModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.Runtime.FFIInspect"
debuggerRuntimeFFIInspectContents :: StringBuffer
debuggerRuntimeFFIInspectContents :: StringBuffer
debuggerRuntimeFFIInspectContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger/GHC/Debugger/Runtime/FFIInspect.hs")
#endif
debuggerRuntimeInternalModName :: ModuleName
debuggerRuntimeInternalModName :: ModuleName
debuggerRuntimeInternalModName = String -> ModuleName
mkModuleName String
"GHC.Debugger.Runtime.Internal"
debuggerRuntimeInternalContents :: StringBuffer
debuggerRuntimeInternalContents :: StringBuffer
debuggerRuntimeInternalContents = String -> StringBuffer
stringToStringBuffer $(embedStringFile =<< makeRelativeToProject "haskell-debugger/GHC/Debugger/Runtime/Internal.hs")
debuggerRuntimeInternalModule :: Module
debuggerRuntimeInternalModule :: Module
debuggerRuntimeInternalModule = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule Unit
debuggerRuntimeInternalUnit ModuleName
debuggerRuntimeInternalModName
debuggerRuntimeInternalUnit :: Unit
debuggerRuntimeInternalUnit :: Unit
debuggerRuntimeInternalUnit = Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
debuggerInternalUnitId)