Commit ee03fe2f authored by mnislaih's avatar mnislaih
Browse files

Restore tidying up of tyvars in :print

It wasn't a good idea to disable it
parent fcb8fd3a
......@@ -18,6 +18,7 @@ import RtClosureInspect
import HscTypes
import IdInfo
--import Id
import Name
import Var hiding ( varName )
import VarSet
import VarEnv
......@@ -61,9 +62,10 @@ pprintClosureCommand session bindThings force str = do
-- 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
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'
......@@ -100,6 +102,17 @@ pprintClosureCommand session bindThings force str = do
ictxt' = ictxt { ic_type_env = type_env' }
writeIORef ref (hsc_env {hsc_IC = ictxt'})
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
hsc_env <- readIORef ref
let env_tvs = ic_tyvars (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 :: Session -> Term -> IO Term
......
......@@ -22,6 +22,8 @@ module RtClosureInspect(
isFullyEvaluated,
isPointed,
isFullyEvaluatedTerm,
mapTermType,
termTyVars
-- unsafeDeepSeq,
) where
......@@ -284,6 +286,18 @@ idTermFoldM = TermFold {
fSuspension = (((return.).).). Suspension
}
mapTermType f = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (fmap f mb_ty) hval n }
termTyVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
fSuspension = \_ mb_ty _ _ ->
maybe emptyVarEnv tyVarsOfType mb_ty,
fPrim = \ _ _ -> emptyVarEnv }
where concatVarEnv = foldr plusVarEnv emptyVarEnv
----------------------------------
-- Pretty printing of terms
----------------------------------
......@@ -374,7 +388,7 @@ type TR a = TcM a
runTR :: HscEnv -> TR Term -> IO Term
runTR hsc_env c = do
mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
case mb_term of
Nothing -> panic "Can't unify"
Just term -> return term
......@@ -475,17 +489,14 @@ cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
tv <- liftM mkTyVarTy (newVar argTypeKind)
case mb_ty of
Nothing -> go tv tv hval
Just ty | isMonomorphic ty -> go ty ty hval
Nothing -> go tv tv hval >>= zonkTerm
Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
Just ty -> do
(ty',rev_subst) <- instScheme (sigmaType ty)
addConstraint tv ty'
term <- go tv tv hval
term <- go tv tv hval >>= zonkTerm
--restore original Tyvars
return$ flip foldTerm term idTermFold {
fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
return$ mapTermType (substTy rev_subst) term
where
go tv ty a = do
let monomorphic = not(isTyVarTy tv) -- This is a convention. The ancestor tests for
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment