-- | This is a modified copy of compiler/ghci/Debugger.hs
{-# LANGUAGE MagicHash, CPP #-}
module Break (
evaluateIds
, resolveNames
, parseNames
) where
import Prelude hiding (id)
import Linker
import RtClosureInspect
import GhcMonad
import HscTypes
import Id
import Name
import Var hiding ( varName )
import VarSet
import UniqSupply
import TcType (
emptyTvSubst
, TvSubst
, substTy
, isUnliftedTypeKind
, unionTvSubst
)
import GHC
import MonadUtils
import Control.Monad
import Data.List
import Data.Maybe
import Data.IORef
import GhcShim
-------------------------------------
-- | The :print & friends commands
-------------------------------------
-- | This is basically 'pprintClosureCommand' from Debugger.hs except that
-- we don't take a string as argument but a set of names (and defined a
-- separate 'parseNames' and 'resolveNames' if we do want to start with a
-- String), and that we return a set of terms rather than pretty-printing
-- them directly to stdout.
evaluateIds :: GhcMonad m => Bool -> Bool -> [Id] -> m [(Id, Term)]
evaluateIds bindThings force ids = do
-- Obtain the terms and the recovered type information
(subst, terms) <- mapAccumLM go emptyTvSubst ids
-- Apply the substitutions obtained after recovering the types
modifySession $ \hsc_env ->
hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
return (zip ids terms)
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
go subst id = do
let id' = id `setIdType` substTy subst (idType id)
term_ <- GHC.obtainTermFromId maxBound force id'
term <- tidyTermTyVars term_
term' <- if bindThings &&
False == isUnliftedTypeKind (termType term)
then bindSuspensions term
else return term
-- Before leaving, we compare the type obtained to see if it's more specific
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let reconstructed_type = termType term
hsc_env <- getSession
case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
Nothing -> return (subst, term')
Just subst' -> return (subst `unionTvSubst` subst', term')
tidyTermTyVars :: GhcMonad m => Term -> m Term
tidyTermTyVars t =
withSession $ \hsc_env -> do
let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
my_tvs = termTyVars t
tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName
tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
, env_tvs `intersectVarSet` my_tvs)
return$ mapTermType (snd . tidyOpenType tidyEnv) t
-- | Give names, and bind in the interactive environment, to all the suspensions
-- included (inductively) in a term
bindSuspensions :: GhcMonad m => Term -> m Term
#if __GLASGOW_HASKELL__ >= 710
-- TODO: Not implemented for 7.10 and up
bindSuspensions _ = undefined
#else
bindSuspensions t = do
hsc_env <- getSession
inScope <- GHC.getBindings
let ictxt = hsc_IC hsc_env
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContext ictxt (map AnId ids)
liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t'
where
-- Processing suspensions. Give names and recopilate info
nameSuspensionsAndGetInfos :: IORef [String] ->
TermFold (IO (Term, [(Name,Type,HValue)]))
nameSuspensionsAndGetInfos freeNames = TermFold
{
fSuspension = doSuspension freeNames
, fTerm = \ty dc v acts -> do
tt' <- sequence acts
let (terms,names) = unzip tt'
return (Term ty dc v terms, concat names)
, fPrim = \ty n ->return (Prim ty n,[])
, fNewtypeWrap =
\ty dc act -> do
(term, names) <- act
return (NewtypeWrap ty dc term, names)
, fRefWrap = \ty act -> do
(term, names) <- act
return (RefWrap ty term, names)
}
doSuspension freeNames ct ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
n <- newGrimName name
return (Suspension ct ty hval (Just n), [(n,ty,hval)])
#endif
-- Create new uniques and give them sequentially numbered names
newGrimName :: MonadIO m => String -> m Name
newGrimName userName = do
us <- liftIO $ mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcSpan
return name
{------------------------------------------------------------------------------
Resolving names
------------------------------------------------------------------------------}
resolveNames :: GhcMonad m => [Name] -> m [Id]
resolveNames names = do
tyThings <- catMaybes `liftM` mapM lookupName names
return $ idsFromTyThings tyThings
where
idsFromTyThings :: [TyThing] -> [Id]
idsFromTyThings = catMaybes . map aux
where
aux (AnId id) = Just id
aux _ = Nothing
parseNames :: GhcMonad m => String -> m [Name]
parseNames str = concatMapM parseName (words str)