-cvObtainTerm hsc_env force mb_ty a =
- -- Obtain the term and tidy the type before returning it
- cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
- 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
-
-cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
- tv <- liftM mkTyVarTy (newVar argTypeKind)
- when (isJust mb_ty) $
- instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
- go tv hval
+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 >>= 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 >>= zonkTerm
+ --restore original Tyvars
+ return$ mapTermType (substTy rev_subst) term