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
+ term' <- if bindThings &&
+ False == isUnliftedTypeKind (termType term)
+ then bindSuspensions cms 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 Just reconstructed_type = termType term
- subst = unifyRTTI (idType id) (reconstructed_type)
- return (term',subst)
+ let reconstructed_type = termType term
+ mb_subst <- withSession cms $ \hsc_env ->
+ improveRTTIType hsc_env (idType id) (reconstructed_type)
+ return (term', fromMaybe emptyTvSubst mb_subst)
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
\ty dc t -> do
(term, names) <- t
return (NewtypeWrap ty dc term, names)
+ , fRefWrap = \ty t -> do
+ (term, names) <- t
+ return (RefWrap ty term, names)
}
- doSuspension freeNames ct mb_ty hval _name = do
+ doSuspension freeNames ct ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
n <- newGrimName name
- let ty' = fromMaybe (error "unexpected") mb_ty
- return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
+ return (Suspension ct ty hval (Just n), [(n,ty,hval)])
-- A custom Term printer to enable the use of Show instances
GHC.setSessionDynFlags cms dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
- cPprShowable _ _ = panic "cPprShowable - unreachable"
+ cPprShowable _ _ = return Nothing
needsParens ('"':_) = False -- some simple heuristics to see whether parens
-- are redundant in an arbitrary Show output