{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,
   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,
   TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf, OverloadedRecordDot #-}
module GHC.Debugger.Stopped.Frames
 ( getStackFrameBindings
 , addIdsToInteractiveContext
 )
 where

import Control.Monad
import Control.Monad.Reader
import qualified Data.List as L
import qualified Data.Map.Strict as Map

import GHC
import GHC.ByteCode.Breakpoints
import GHC.Data.Maybe
import GHC.Driver.Env as GHC
import GHC.Runtime.Eval
import GHC.Utils.Outputable as Ppr

import GHC.Debugger.Monad
import GHC.Debugger.Interface.Messages
import GHC.Debugger.Utils
import qualified Colog.Core as Logger
import qualified GHC.Plugins as GHC
import qualified GHC.Tc.Utils.Monad as GHC
import qualified GHC.IfaceToCore as GHC
import qualified GHC.Linker.Loader as Loader
import qualified GHC.Exts.Heap.Closures as GHC
import qualified GHC.Types.Id as Id
import GHC.Iface.Env (newInteractiveBinder)
import qualified GHC.Runtime.Context as GHC
import qualified GHC.Core.Predicate as GHC
import qualified GHC.Core.TyCo.Tidy as GHC
import qualified GHC.Types.RepType as GHC
import qualified GHC.Tc.Utils.TcType as GHC
import qualified GHC.Utils.Logger as GHC
import qualified GHC.Core.TyCo.Ppr as GHC
import qualified GHC.Runtime.Heap.Inspect as GHC
import GHCi.RemoteTypes (ForeignRef)
#if MIN_VERSION_ghc(9,14,2)
import GHC.Linker.Types
import qualified GHC.Debugger.Runtime.Interpreter as Debuggee
#else
import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee
#endif

-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
-- whenever we stop at a breakpoint.  The InteractveContext is properly
-- saved/restored, but not the linker state.  See #1743, test break026.
mkNewId :: HscEnv -> GHC.FastString -> GHC.Type -> Maybe Id -> IO Id
mkNewId :: HscEnv -> FastString -> Type -> Maybe Id -> IO Id
mkNewId HscEnv
hsc_env FastString
occ Type
ty Maybe Id
old_id
  = do { name <- HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env (FastString -> OccName
GHC.mkVarOccFS FastString
occ) (SrcSpan -> Maybe SrcSpan -> SrcSpan
forall a. a -> Maybe a -> a
fromMaybe SrcSpan
GHC.interactiveSrcSpan (Maybe SrcSpan -> SrcSpan) -> Maybe SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
GHC.getSrcSpan (Id -> SrcSpan) -> Maybe Id -> Maybe SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Id
old_id)
          -- NB: use variable namespace.
          -- Don't use record field namespaces, lest we cause #25109.
      ; return $ Id.mkVanillaGlobalWithInfo name ty (fromMaybe GHC.vanillaIdInfo $ GHC.idInfo <$> old_id) }

getStackFrameBindings :: DbgStackFrame -> Debugger [Id]
getStackFrameBindings :: DbgStackFrame -> Debugger [Id]
getStackFrameBindings frame :: DbgStackFrame
frame@DbgStackFrame{breakId :: DbgStackFrame -> Maybe InternalBreakpointId
breakId = Maybe InternalBreakpointId
ibi,args :: DbgStackFrame -> Maybe (DbgStackFrameBCOArgs ForeignRef)
args = Maybe (DbgStackFrameBCOArgs ForeignRef)
Nothing} = do
  Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"getStackFrameBindings: no args. ibi,frame =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe InternalBreakpointId -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe InternalBreakpointId
ibi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"," SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (DbgStackFrame -> String
forall a. Show a => a -> String
show DbgStackFrame
frame)
  [Id] -> Debugger [Id]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getStackFrameBindings DbgStackFrame{breakId :: DbgStackFrame -> Maybe InternalBreakpointId
breakId = Maybe InternalBreakpointId
ibi0, args :: DbgStackFrame -> Maybe (DbgStackFrameBCOArgs ForeignRef)
args = Just (DbgStackFrameBCOArgs (NoShow ForeignRef [StackField]
bcoArgsRef) Maybe Word
offset0)}  = do
  case (Maybe InternalBreakpointId
ibi0, Maybe Word
offset0) of
    (Just InternalBreakpointId
ibi, Just Word
offset)
      -> do
#ifdef TESTING
      -- Making sure the fallback path doesn't crash.
      -- It was hard to directly trigger.
      fids <- ForeignRef [StackField] -> Debugger [Id]
bindFrameVarsWithNoInfo ForeignRef [StackField]
bcoArgsRef
      logSDoc Logger.Debug $ text "fallback ids" <+> ppr fids
#endif
      bindFrameVarsWithBreakpointInfo ibi bcoArgsRef offset
    (Maybe InternalBreakpointId, Maybe Word)
_ -> ForeignRef [StackField] -> Debugger [Id]
bindFrameVarsWithNoInfo ForeignRef [StackField]
bcoArgsRef

bindFrameVarsWithNoInfo :: ForeignRef [GHC.StackField] -> Debugger [Id]
bindFrameVarsWithNoInfo :: ForeignRef [StackField] -> Debugger [Id]
bindFrameVarsWithNoInfo ForeignRef [StackField]
bcoArgsRef = do
    bcoArgs <- ForeignRef [StackField] -> Maybe [Int] -> Debugger [ForeignHValue]
Debuggee.unpackStackFields ForeignRef [StackField]
bcoArgsRef Maybe [Int]
forall a. Maybe a
Nothing
    hsc_env <- getSession
    let artificial = (ForeignHValue -> Int -> IO (Id, ForeignHValue, OccName))
-> [ForeignHValue] -> [Int] -> [IO (Id, ForeignHValue, OccName)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ForeignHValue -> Int -> IO (Id, ForeignHValue, OccName)
forall {a} {b}. Show a => b -> a -> IO (Id, b, OccName)
fa [ForeignHValue]
bcoArgs [Int
0 :: Int ..]
          where
            fa :: b -> a -> IO (Id, b, OccName)
fa b
fv a
i = do
              id' <- HscEnv -> FastString -> Type -> Maybe Id -> IO Id
mkNewId HscEnv
hsc_env (String -> FastString
GHC.mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"_a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i) (Type -> Type
GHC.anyTypeOfKind Type
GHC.liftedTypeKind) Maybe Id
forall a. Maybe a
Nothing
              pure $ (id', fv, getOccName id')
    arts <- liftIO $ sequence artificial
    liftIO $ bindForeignHValues hsc_env arts

bindFrameVarsWithBreakpointInfo :: InternalBreakpointId -> ForeignRef [GHC.StackField] -> Word -> Debugger [Id]
bindFrameVarsWithBreakpointInfo :: InternalBreakpointId
-> ForeignRef [StackField] -> Word -> Debugger [Id]
bindFrameVarsWithBreakpointInfo InternalBreakpointId
ibi ForeignRef [StackField]
bcoArgs Word
delta0 = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let hug = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env

  info_brks <- liftIO $ readIModBreaks hug ibi
  occs <- liftIO $ getBreakVars (readIModModBreaks hug) ibi info_brks
  let info  = InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
getInternalBreak InternalBreakpointId
ibi InternalModBreaks
info_brks
  let delta = Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
delta0
  (mbVars, _result_ty) <- liftIO $ GHC.initIfaceLoad hsc_env
                    $ GHC.initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot
                    $ GHC.hydrateCgBreakInfo info
  unless (length mbVars == length occs) $ do
    logSDoc Logger.Warning $ text "different length of cgb_vars and getBreakVars for ibi" <+> ppr mbVars <+> ppr occs <+> ppr ibi
  let mbVarsIx = ((Maybe (Id, Word) -> Maybe (Id, Word))
 -> [Maybe (Id, Word)] -> [Maybe (Id, Word)])
-> [Maybe (Id, Word)]
-> (Maybe (Id, Word) -> Maybe (Id, Word))
-> [Maybe (Id, Word)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Id, Word) -> Maybe (Id, Word))
-> [Maybe (Id, Word)] -> [Maybe (Id, Word)]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe (Id, Word)]
mbVars ((Maybe (Id, Word) -> Maybe (Id, Word)) -> [Maybe (Id, Word)])
-> (Maybe (Id, Word) -> Maybe (Id, Word)) -> [Maybe (Id, Word)]
forall a b. (a -> b) -> a -> b
$ \Maybe (Id, Word)
x -> Maybe (Id, Word)
x Maybe (Id, Word)
-> ((Id, Word) -> Maybe (Id, Word)) -> Maybe (Id, Word)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Id
var,Word
offset) -> (Id
var,) (Word -> (Id, Word)) -> Maybe Word -> Maybe (Id, Word)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word
offset Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
delta)
        Word -> Maybe Word
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
offset Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
delta)
  let discarded = [(Maybe (Id, Word), Maybe (Id, Word))
p | p :: (Maybe (Id, Word), Maybe (Id, Word))
p@(Just (Id, Word)
_, Maybe (Id, Word)
Nothing) <- [Maybe (Id, Word)]
-> [Maybe (Id, Word)] -> [(Maybe (Id, Word), Maybe (Id, Word))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe (Id, Word)]
mbVars [Maybe (Id, Word)]
mbVarsIx]
  unless (null discarded) $ do
    logSDoc Logger.Warning $ text "Variables discarded due to (offset - delta) underflow: delta =" <+> ppr delta <+> text "," <+> ppr discarded
  let varsIxs = [(Int, (Id, Word))] -> Map Int (Id, Word)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Int
pos :: Int,(Id, Word)
v) | (Int
pos,Just (Id, Word)
v) <- [Int] -> [Maybe (Id, Word)] -> [(Int, Maybe (Id, Word))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Maybe (Id, Word)]
mbVarsIx]

  let joinOccs Map k (a, b)
m = Map k (a, b, OccName) -> [(a, b, OccName)]
forall k a. Map k a -> [a]
Map.elems (Map k (a, b, OccName) -> [(a, b, OccName)])
-> Map k (a, b, OccName) -> [(a, b, OccName)]
forall a b. (a -> b) -> a -> b
$ ((a, b) -> OccName -> (a, b, OccName))
-> Map k (a, b) -> Map k OccName -> Map k (a, b, OccName)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (\(a
x,b
y) OccName
z -> (a
x,b
y,OccName
z)) Map k (a, b)
m ([(k, OccName)] -> Map k OccName
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, OccName)] -> Map k OccName)
-> [(k, OccName)] -> Map k OccName
forall a b. (a -> b) -> a -> b
$ [k] -> [OccName] -> [(k, OccName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k
0..] [OccName]
occs)

  fhvs <- joinOccs <$> do
    withMapElems varsIxs $ \ [(Id, Word)]
xs -> [(Id, Word)]
-> ([Word] -> Debugger [ForeignHValue])
-> Debugger [(Id, ForeignHValue)]
forall (m :: * -> *) a b c.
Monad m =>
[(a, b)] -> ([b] -> m [c]) -> m [(a, c)]
withListElems [(Id, Word)]
xs (([Word] -> Debugger [ForeignHValue])
 -> Debugger [(Id, ForeignHValue)])
-> ([Word] -> Debugger [ForeignHValue])
-> Debugger [(Id, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$
      ForeignRef [StackField] -> Maybe [Int] -> Debugger [ForeignHValue]
Debuggee.unpackStackFields ForeignRef [StackField]
bcoArgs (Maybe [Int] -> Debugger [ForeignHValue])
-> ([Word] -> Maybe [Int]) -> [Word] -> Debugger [ForeignHValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int])
-> ([Word] -> [Int]) -> [Word] -> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Int) -> [Word] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

  liftIO $ bindForeignHValues hsc_env fhvs
    where
      withListElems :: Monad m => [(a,b)] -> ([b] -> m [c]) -> m [(a,c)]
      withListElems :: forall (m :: * -> *) a b c.
Monad m =>
[(a, b)] -> ([b] -> m [c]) -> m [(a, c)]
withListElems [(a, b)]
xs [b] -> m [c]
f = do
        let ([a]
as,[b]
bs) = [(a, b)] -> ([a], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, b)]
xs
        bs' <- [b] -> m [c]
f [b]
bs
        pure $ zip as bs'

      withMapElems :: (Monad m, Ord a) => Map.Map a b -> ([b] -> m [c]) -> m (Map.Map a c)
      withMapElems :: forall (m :: * -> *) a b c.
(Monad m, Ord a) =>
Map a b -> ([b] -> m [c]) -> m (Map a c)
withMapElems Map a b
m [b] -> m [c]
f = [(a, c)] -> Map a c
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, c)] -> Map a c) -> m [(a, c)] -> m (Map a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b)] -> ([b] -> m [c]) -> m [(a, c)]
forall (m :: * -> *) a b c.
Monad m =>
[(a, b)] -> ([b] -> m [c]) -> m [(a, c)]
withListElems (Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a b
m) [b] -> m [c]
f

-- | Modeled after bindLocalsAtBreakpoint
--   Returns new Ids generated from the given ones and OccNames, with refreshed free type variables.
--   The values are bound to the new Ids in the loader state.
bindForeignHValues :: HscEnv -> [(Id, ForeignHValue, GHC.OccName)] -> IO [Id]
bindForeignHValues :: HscEnv -> [(Id, ForeignHValue, OccName)] -> IO [Id]
bindForeignHValues HscEnv
hsc_env [(Id, ForeignHValue, OccName)]
mbVals = do
  let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
  let
    -- Filter out any unboxed ids by changing them to Nothings;
    -- we can't bind these at the prompt

    -- TODO: do we have the same restriction in hdb?
    mbPointers :: [(Id, ForeignHValue, OccName)]
mbPointers = [(Id, ForeignHValue, OccName)
x | x :: (Id, ForeignHValue, OccName)
x@(Id
id',ForeignHValue
_,OccName
_) <- [(Id, ForeignHValue, OccName)]
mbVals, Id -> Bool
isPointer Id
id']

    ([Id]
ids, [ForeignHValue]
hvalues, [OccName]
occs) = [(Id, ForeignHValue, OccName)]
-> ([Id], [ForeignHValue], [OccName])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Id, ForeignHValue, OccName)]
mbPointers

  new_ids     <- [Id] -> [OccName] -> IO [Id]
mkNewIds [Id]
ids [OccName]
occs

  let names  = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
GHC.idName [Id]
new_ids

  let fhvs = [ForeignHValue]
hvalues
  Loader.extendLoadedEnv interp
#if MIN_VERSION_ghc(9,14,2)
      modifyHomePackageBytecodeState
#endif
      (zip names fhvs)
  return new_ids
  where
    mkNewIds :: [Id] -> [OccName] -> IO [Id]
mkNewIds [Id]
ids [OccName]
occs = do
      let
        free_tvs :: [Id]
free_tvs = [Type] -> [Id]
GHC.tyCoVarsOfTypesWellScoped ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
ids)

      us <- Char -> IO UniqSupply
GHC.mkSplitUniqSupply
#if MIN_VERSION_ghc(9,14,2)
              GHC.BcoTag
#else
              Char
'b'
#endif
      let tv_subst     = UniqSupply -> [Id] -> Subst
newTyVars UniqSupply
us [Id]
free_tvs
          tidy_tys = TidyEnv -> [Type] -> [Type]
GHC.tidyOpenTypes TidyEnv
GHC.emptyTidyEnv ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
                      (Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
GHC.substTy Subst
tv_subst (Type -> Type) -> (Id -> Type) -> Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
ids
          mkNewId' OccName
occ Type
ty Id
id' = HscEnv -> FastString -> Type -> Maybe Id -> IO Id
mkNewId HscEnv
hsc_env (OccName -> FastString
GHC.occNameFS OccName
occ) Type
ty (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id')
      GHC.zipWith3M mkNewId' occs tidy_tys ids

    mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
    mkRuntimeUnkTyVar :: Name -> Type -> Id
mkRuntimeUnkTyVar Name
name Type
kind = Name -> Type -> TcTyVarDetails -> Id
GHC.mkTcTyVar Name
name Type
kind TcTyVarDetails
GHC.RuntimeUnk

    newTyVars :: GHC.UniqSupply -> [GHC.TcTyVar] -> GHC.Subst
     -- Similarly, clone the type variables mentioned in the types
     -- we have here, *and* make them all RuntimeUnk tyvars
    newTyVars :: UniqSupply -> [Id] -> Subst
newTyVars UniqSupply
us [Id]
tvs = (Subst -> (Id, Unique) -> Subst)
-> Subst -> [(Id, Unique)] -> Subst
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Subst -> (Id, Unique) -> Subst
mk_new_tv Subst
GHC.emptySubst ([Id]
tvs [Id] -> [Unique] -> [(Id, Unique)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
GHC.uniqsFromSupply UniqSupply
us)
    mk_new_tv :: Subst -> (Id, Unique) -> Subst
mk_new_tv Subst
subst (Id
tv,Unique
uniq) = Subst -> Id -> Id -> Subst
GHC.extendTCvSubstWithClone Subst
subst Id
tv Id
new_tv
      where
        new_tv :: Id
new_tv = Name -> Type -> Id
mkRuntimeUnkTyVar (Name -> Unique -> Name
GHC.setNameUnique (Id -> Name
GHC.tyVarName Id
tv) Unique
uniq)
                                (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
GHC.substTy Subst
subst (Id -> Type
GHC.tyVarKind Id
tv))

    isPointer :: Id -> Bool
isPointer Id
id' | [PrimRep
rep] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
GHC.typePrimRep (Id -> Type
idType Id
id')
                  , PrimRep -> Bool
GHC.isGcPtrRep PrimRep
rep = Bool
True
                  | Bool
otherwise          = Bool
False

-- | Extends the InteractiveContext with the given Ids, setting up the RTTI information.
--   Assumes the Ids' Names are already known to the Loader.
addIdsToInteractiveContext :: HscEnv -> [Id] -> IO HscEnv
addIdsToInteractiveContext :: HscEnv -> [Id] -> IO HscEnv
addIdsToInteractiveContext HscEnv
hsc_env [Id]
final_ids = do
   let
       ictxt0 :: InteractiveContext
ictxt0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
       ictxt1 :: InteractiveContext
ictxt1 = InteractiveContext -> [Id] -> InteractiveContext
GHC.extendInteractiveContextWithIds InteractiveContext
ictxt0 [Id]
final_ids
   HscEnv -> IO HscEnv
rttiEnvironment HscEnv
hsc_env{ hsc_IC = ictxt1 }

rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env0 :: HscEnv
hsc_env0@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic0} = do
   let tmp_ids :: [Id]
tmp_ids = [Id
id' | AnId Id
id' <- InteractiveContext -> [TyThing]
GHC.ic_tythings InteractiveContext
ic0]
       incompletelyTypedIds :: [Id]
incompletelyTypedIds =
           [Id
id' | Id
id' <- [Id]
tmp_ids
               , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Bool
noSkolems Id
id'
               , (OccName -> FastString
GHC.occNameFS (OccName -> FastString) -> (Id -> OccName) -> Id -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
GHC.nameOccName (Name -> OccName) -> (Id -> Name) -> Id -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
GHC.idName) Id
id' FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FastString
result_fs]
   (HscEnv -> Name -> IO HscEnv) -> HscEnv -> [Name] -> IO HscEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HscEnv -> Name -> IO HscEnv
improveTypes HscEnv
hsc_env0 ((Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
GHC.idName [Id]
incompletelyTypedIds)
    where
     result_fs :: GHC.FastString
     result_fs :: FastString
result_fs = String -> FastString
GHC.fsLit String
"_result"

     noSkolems :: Id -> Bool
noSkolems = Type -> Bool
GHC.noFreeVarsOfType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType
     improveTypes :: HscEnv -> Name -> IO HscEnv
improveTypes hsc_env :: HscEnv
hsc_env@HscEnv{hsc_IC :: HscEnv -> InteractiveContext
hsc_IC=InteractiveContext
ic} Name
name = do
      let tmp_ids :: [Id]
tmp_ids = [Id
id' | AnId Id
id' <- InteractiveContext -> [TyThing]
GHC.ic_tythings InteractiveContext
ic]
      let
          id' :: Id
id' = Maybe Id -> Id
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe Id -> Id) -> Maybe Id -> Id
forall a b. (a -> b) -> a -> b
$ (Id -> Bool) -> [Id] -> Maybe Id
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\Id
i -> Id -> Name
GHC.idName Id
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) [Id]
tmp_ids
      if Id -> Bool
noSkolems Id
id'
         then HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
         else do
           mb_new_ty <- HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType HscEnv
hsc_env Int
10 Id
id'
           let old_ty = Id -> Type
idType Id
id'
           case mb_new_ty of
             Maybe Type
Nothing -> HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
             Just Type
new_ty -> do
              case HscEnv -> Type -> Type -> Maybe Subst
GHC.improveRTTIType HscEnv
hsc_env Type
old_ty Type
new_ty of
               Maybe Subst
Nothing -> Bool -> String -> SDoc -> IO HscEnv -> IO HscEnv
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True (String
":print failed to calculate the "
                                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"improvement for a type")
                              ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id'
                                    , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"old_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
GHC.debugPprType Type
old_ty
                                    , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"new_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
GHC.debugPprType Type
new_ty ]) (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                          HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
               Just Subst
subst -> do
                 let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
                 Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
GHC.putDumpFileMaybe Logger
logger DumpFlag
GHC.Opt_D_dump_rtti String
"RTTI"
                   DumpFormat
GHC.FormatText
                   ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RTTI Improvement for", Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id', SDoc
forall doc. IsLine doc => doc
equals,
                          Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst])

                 let ic' :: InteractiveContext
ic' = InteractiveContext -> Subst -> InteractiveContext
GHC.substInteractiveContext InteractiveContext
ic Subst
subst
                 HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{hsc_IC=ic'}