Improve error message layout slightly

[ghc-hetmet.git] / compiler / typecheck / TcUnify.lhs

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 7ce2fca..709b7c4 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -60,6 +60,7 @@ import BasicTypes
 import Util
 import Outputable
 import Unique
+import FastString
 
 import Control.Monad
 \end{code}
@@ -615,6 +616,12 @@ boxy_match tmpl_tvs orig_tmpl_ty boxy_tvs orig_boxy_ty subst
                        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
@@ -643,6 +650,10 @@ boxyLub orig_ty1 orig_ty2
       | 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'
@@ -904,12 +915,13 @@ tcGen expected_ty extra_tvs thing_inside  -- We expect expected_ty to be a forall
                   ; 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')
@@ -1487,17 +1499,17 @@ uMetaVar outer swapped tv1 BoxTv ref1 ps_ty2 non_var_ty2
        -- 
        -- 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
         }