Commit f3e5a3ad authored by mnislaih's avatar mnislaih

fix :print reconstructing too many types in environment bindings

For more details, see test print019
parent de73aab4
......@@ -66,7 +66,7 @@ import GHC.Word ( Word32(..), Word64(..) )
import Control.Monad
import Data.Maybe
import Data.Array.Base
import Data.List ( partition )
import Data.List ( partition, nub )
import Foreign.Storable
import IO
......@@ -475,18 +475,25 @@ cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm hsc_env force mb_ty a = do
-- Obtain the term and tidy the type before returning it
term <- cvObtainTerm1 hsc_env force mb_ty a
return $ tidyTypes term
where
tidyTypes = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (fmap tidy mb_ty) hval n
}
tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
tidyVarEnv ty = mkVarEnv$
[ (v, setTyVarName v (tyVarName tv))
| (tv,v) <- zip alphaTyVars vars]
where vars = varSetElems$ tyVarsOfType ty
let term' = tidyTypes term
return term'
where allvars = nub . foldTerm TermFold {
fTerm = \ty _ _ tt ->
varEnvElts(tyVarsOfType ty) ++ concat tt,
fSuspension = \_ mb_ty _ _ ->
maybe [] (varEnvElts . tyVarsOfType) mb_ty,
fPrim = \ _ _ -> [] }
tidyTypes term = let
go = foldTerm idTermFold {
fTerm = \ty dc hval tt ->
Term (tidy ty) dc hval tt,
fSuspension = \ct mb_ty hval n ->
Suspension ct (fmap tidy mb_ty) hval n }
tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv) ty
tidyVarEnv = mkVarEnv$
[ (v, alpha_tv `setTyVarUnique` varUnique v)
| (alpha_tv,v) <- zip alphaTyVars (allvars term)]
in go term
cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
......
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