--
-----------------------------------------------------------------------------
-module Debugger (pprintClosureCommand) where
+module Debugger (pprintClosureCommand, showTerm) where
import Linker
import RtClosureInspect
import TcType
import TcGadt
import GHC
-
+import GhciMonad
+import InteractiveEval
import Outputable
import Pretty ( Mode(..), showDocWith )
import FastString
import GHC.Exts
#include "HsVersions.h"
-
-------------------------------------
-- | The :print & friends commands
-------------------------------------
mapM (\w -> GHC.parseName session w >>=
mapM (GHC.lookupName session))
(words str)
- substs <- catMaybes `liftM` mapM (go session)
- [id | AnId id <- tythings]
- mapM (applySubstToEnv session . skolemSubst) substs
- return ()
- where
+ let ids = [id | AnId id <- tythings]
+
+ -- Obtain the terms and the recovered type information
+ (terms, substs) <- unzip `liftM` mapM (go session) ids
+
+ -- Apply the substitutions obtained after recovering the types
+ modifySession session $ \hsc_env ->
+ hsc_env{hsc_IC = foldr (flip substInteractiveContext)
+ (hsc_IC hsc_env)
+ (map skolemiseSubst substs)}
+ -- Finally, print the Terms
+ unqual <- GHC.getPrintUnqual session
+ let showSDocForUserOneLine unqual doc =
+ showDocWith LeftMode (doc (mkErrStyle unqual))
+ docterms <- mapM (showTerm session) terms
+ (putStrLn . showSDocForUserOneLine unqual . vcat)
+ (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
+ ids
+ docterms)
+ where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
- go :: Session -> Id -> IO (Maybe TvSubst)
- go cms id = do
- mb_term <- obtainTerm cms force id
- maybe (return Nothing) `flip` mb_term $ \term_ -> do
- term <- tidyTermTyVars cms term_
- term' <- if not bindThings then return term
- else bindSuspensions cms term
- showterm <- printTerm cms term'
- unqual <- GHC.getPrintUnqual cms
- let showSDocForUserOneLine unqual doc =
- showDocWith LeftMode (doc (mkErrStyle unqual))
- (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+ go :: Session -> Id -> IO (Term, TvSubst)
+ go cms id = do
+ term_ <- GHC.obtainTerm cms force id
+ term <- tidyTermTyVars cms term_
+ term' <- if not bindThings then return term
+ else bindSuspensions cms term
-- Before leaving, we compare the type obtained to see if it's more specific
- -- Then, we extract a substitution,
+ -- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let Just reconstructed_type = termType term
-
- -- tcUnifyTys doesn't look through forall's, so we drop them from
- -- the original type, instead of sigma-typing the reconstructed type
- -- In addition, we strip newtypes too, since the reconstructed type might
- -- not have recovered them all
- mb_subst = tcUnifyTys (const BindMe)
- [repType' $ dropForAlls$ idType id]
- [repType' $ reconstructed_type]
-
- ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id))
- return mb_subst
-
- applySubstToEnv :: Session -> TvSubst -> IO ()
- applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
- applySubstToEnv cms@(Session ref) subst = do
- hsc_env <- readIORef ref
- inScope <- GHC.getBindings cms
- let ictxt = hsc_IC hsc_env
- ids = ic_tmp_ids ictxt
- ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids
- subst_dom= varEnvKeys$ getTvSubstEnv subst
- subst_ran= varEnvElts$ getTvSubstEnv subst
- new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran]
- ic_tyvars'= (`delVarSetListByKey` subst_dom)
- . (`extendVarSetList` new_tvs)
- $ ic_tyvars ictxt
- ictxt' = ictxt { ic_tmp_ids = ids'
- , ic_tyvars = ic_tyvars' }
- writeIORef ref (hsc_env {hsc_IC = ictxt'})
-
- where delVarSetListByKey = foldl' delVarSetByKey
+ Just subst = computeRTTIsubst (idType id) (reconstructed_type)
+ return (term',subst)
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
- let tys' = map mk_skol_ty tys
+ let tys' = map (fst.skolemiseTy) tys
let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
| (name,ty) <- zip names tys']
new_tyvars = tyVarsOfTypes tys'
where
-- Processing suspensions. Give names and recopilate info
- nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
+ nameSuspensionsAndGetInfos :: IORef [String] ->
+ TermFold (IO (Term, [(Name,Type,HValue)]))
nameSuspensionsAndGetInfos freeNames = TermFold
{
fSuspension = doSuspension freeNames
GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mb_txt <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr cms expr)
- let myprec = 9 -- TODO Infix constructors
+ let myprec = 10 -- application precedence. TODO Infix constructors
case mb_txt of
- Just txt -> return . Just . text . unsafeCoerce#
- $ txt
- Nothing -> return Nothing
+ Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
+ -> return $ Just$ cparen (prec >= myprec &&
+ needsParens txt)
+ (text txt)
+ _ -> return Nothing
`finally` do
writeIORef ref hsc_env
GHC.setSessionDynFlags cms dflags
-
+ needsParens ('"':txt) = False -- some simple heuristics to see whether parens
+ -- are redundant in an arbitrary Show output
+ needsParens ('(':txt) = False
+ needsParens txt = ' ' `elem` txt
+
+
bindToFreshName hsc_env ty userName = do
name <- newGrimName cms userName
let ictxt = hsc_IC hsc_env
tmp_ids = ic_tmp_ids ictxt
- id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
+ id = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name)
us <- mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
- name = mkInternalName unique occname noSrcLoc
+ name = mkInternalName unique occname noSrcSpan
return name
-
-skolemSubst subst = subst `setTvSubstEnv`
- mapVarEnv mk_skol_ty (getTvSubstEnv subst)
-mk_skol_ty ty | tyvars <- varSetElems (tyVarsOfType ty)
- , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
- = substTyWith tyvars tyvars' ty
-mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv)
- (SkolemTv RuntimeUnkSkol)
projects / ghc-hetmet.git / blobdiff