import Util
import Outputable
import Unique
+import FastString
import Control.Monad
\end{code}
Nothing -> orig_boxy_ty
Just ty -> ty `boxyLub` orig_boxy_ty
+ go _ (TyVarTy tv) | isMetaTyVar tv
+ = subst -- Don't fail if the template has more info than the target!
+ -- Otherwise, with tmpl_tvs = [a], matching (a -> Int) ~ (Bool -> beta)
+ -- would fail to instantiate 'a', because the meta-type-variable
+ -- beta is as yet un-filled-in
+
go _ _ = emptyTvSubst -- It's important to *fail* by returning the empty substitution
-- Example: Tree a ~ Maybe Int
-- We do not want to bind (a |-> Int) in pre-matching, because that can give very
| isTcTyVar tv1, isBoxyTyVar tv1 -- choose ty2 if ty2 is a box
= orig_ty2
+ go ty1 (TyVarTy tv2) -- Symmetrical case
+ | isTcTyVar tv2, isBoxyTyVar tv2
+ = orig_ty1
+
-- Look inside type synonyms, but only if the naive version fails
go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
| Just ty2' <- tcView ty1 = go ty1 ty2'
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
; return ((forall_tvs, theta, rho_ty), skol_info) })
-#ifdef DEBUG
- ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs,
- text "expected_ty" <+> ppr expected_ty,
- text "inst ty" <+> ppr tvs' <+> ppr theta' <+> ppr rho',
- text "free_tvs" <+> ppr free_tvs])
-#endif
+ ; when debugIsOn $
+ traceTc (text "tcGen" <+> vcat [
+ text "extra_tvs" <+> ppr extra_tvs,
+ text "expected_ty" <+> ppr expected_ty,
+ text "inst ty" <+> ppr tvs' <+> ppr theta'
+ <+> ppr rho',
+ text "free_tvs" <+> ppr free_tvs])
-- Type-check the arg and unify with poly type
; (result, lie) <- getLIE (thing_inside tvs' rho')
--
-- It should not be the case that tv1 occurs in ty2
-- (i.e. no occurs check should be needed), but if perchance
- -- it does, the unbox operation will fill it, and the DEBUG
+ -- it does, the unbox operation will fill it, and the debug code
-- checks for that.
- do { final_ty <- unBox ps_ty2
-#ifdef DEBUG
- ; meta_details <- readMutVar ref1
- ; case meta_details of
- Indirect ty -> WARN( True, ppr tv1 <+> ppr ty )
- return () -- This really should *not* happen
- Flexi -> return ()
-#endif
- ; checkUpdateMeta swapped tv1 ref1 final_ty
+ do { final_ty <- unBox ps_ty2
+ ; when debugIsOn $ do
+ { meta_details <- readMutVar ref1
+ ; case meta_details of
+ Indirect ty -> WARN( True, ppr tv1 <+> ppr ty )
+ return () -- This really should *not* happen
+ Flexi -> return ()
+ }
+ ; checkUpdateMeta swapped tv1 ref1 final_ty
; return IdCo
}
--
-- For once, it's safe to treat synonyms as opaque!
-unBox (NoteTy n ty) = do { ty' <- unBox ty; return (NoteTy n ty') }
unBox (TyConApp tc tys) = do { tys' <- mapM unBox tys; return (TyConApp tc tys') }
unBox (AppTy f a) = do { f' <- unBox f; a' <- unBox a; return (mkAppTy f' a') }
unBox (FunTy f a) = do { f' <- unBox f; a' <- unBox a; return (FunTy f' a') }