Fix Trac #4120: generate a proper coercion when unifying forall types

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

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 6426c92..0fe92e0 100644 (file)
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -38,7 +38,6 @@ import Bag
 import Outputable
 import SrcLoc  ( Located(..) )
 import Maybes
-import MonadUtils
 import FastString
 
 -- standard
@@ -316,7 +315,7 @@ no further propoagation is possible.
 --
 normaliseEqs :: [Inst] -> TcM EqConfig
 normaliseEqs eqs 
-  = do { ASSERTM2( allM wantedEqInstIsUnsolved eqs, ppr eqs )
+  = do { WARNM2( anyM wantedEqInstIsUnsolved eqs, ppr eqs )
        ; traceTc $ ptext (sLit "Entering normaliseEqs")
 
        ; eqss <- mapM normEqInst eqs
@@ -795,18 +794,19 @@ flattenType inst ty = go ty
                      thisRewriteFam : concat args_eqss)
            }
 
-      -- data constructor application => flatten subtypes
+      -- datatype constructor application => flatten subtypes
       -- NB: Special cased for efficiency - could be handled as type application
     go ty@(TyConApp con args)
       | not (isOpenSynTyCon con)   -- don't match oversaturated family apps
       = do { (args', cargs, args_eqss) <- mapAndUnzip3M go args
-           ; if null args_eqss
+           ; let args_eqs = concat args_eqss
+           ; if null args_eqs
              then     -- unchanged, keep the old type with folded synonyms
                return (ty, ty, [])
              else 
                return (mkTyConApp con args', 
                        mkTyConApp con cargs,
-                       concat args_eqss)
+                       args_eqs)
            }
 
       -- function type => flatten subtypes
@@ -849,9 +849,32 @@ flattenType inst ty = go ty
       | otherwise
       = panic "TcTyFuns.flattenType: synonym family in a rank-n type"
 
-      -- we should never see a predicate type
-    go (PredTy _)
-      = panic "TcTyFuns.flattenType: unexpected PredType"
+      -- predicate type => handle like a datatype constructor application
+    go (PredTy (ClassP cls tys))
+      = do { (tys', ctys, tys_eqss) <- mapAndUnzip3M go tys
+           ; let tys_eqs = concat tys_eqss
+           ; if null tys_eqs
+             then     -- unchanged, keep the old type with folded synonyms
+               return (ty, ty, [])
+             else 
+               return (PredTy (ClassP cls tys'), 
+                       PredTy (ClassP cls ctys),
+                       tys_eqs)
+           }
+
+      -- implicit parameter => flatten subtype
+    go ty@(PredTy (IParam ipn ity))
+      = do { (ity', co, eqs) <- go ity
+           ; if null eqs 
+             then return (ty, ty, []) 
+             else return (PredTy (IParam ipn ity'),
+                          PredTy (IParam ipn co),
+                          eqs)
+           }
+
+      -- we should never see a equality
+    go (PredTy (EqPred _ _))
+      = panic "TcTyFuns.flattenType: malformed type"
 
     go _ = panic "TcTyFuns: suppress bogus warning"
 
@@ -1576,10 +1599,9 @@ somethingdifferent message.
 eqInstMisMatch :: Inst -> TcM a
 eqInstMisMatch inst
   = ASSERT( isEqInst inst )
-    setErrCtxt ctxt $ failWithMisMatch ty_act ty_exp
+    setInstCtxt (instLoc inst) $ failWithMisMatch ty_act ty_exp
   where
     (ty_act, ty_exp) = eqInstTys inst
-    InstLoc _ _ ctxt = instLoc   inst
 
 -----------------------
 failWithMisMatch :: TcType -> TcType -> TcM a
@@ -1600,15 +1622,20 @@ misMatchMsg env0 (ty_act, ty_exp)
         msg = sep [sep [ptext (sLit "Couldn't match expected type") <+> pp_exp, 
                        nest 7 $
                               ptext (sLit "against inferred type") <+> pp_act],
-                  nest 2 (extra_exp $$ extra_act),
-                  nest 2 (vcat (map pp_open_tc (nub open_tcs)))]
+                  nest 2 (extra_exp $$ extra_act $$ extra_tyfun) ]
                        -- See Note [Non-injective type functions]
     in
     (env2, msg)
 
   where
-    open_tcs = [tc | TyConApp tc _ <- [ty_act, ty_exp]
-                   , isOpenTyCon tc ]
+    extra_tyfun 
+      = case (tcSplitTyConApp_maybe ty_act, tcSplitTyConApp_maybe ty_exp) of
+          (Just (tc_act,_), Just (tc_exp,_)) | tc_act == tc_exp
+              -> if isOpenSynTyCon tc_act then pp_open_tc tc_act
+                 else WARN( True, ppr tc_act) -- If there's a mis-match, then 
+                      empty                  -- it should be a family
+          _ -> empty
+
     pp_open_tc tc = ptext (sLit "NB:") <+> quotes (ppr tc) 
                    <+> ptext (sLit "is a type function") <> pp_inj
        where
@@ -1641,16 +1668,6 @@ It's very confusing to get a message like
 so pp_open_tc adds:
        NB: `Depend' is type function, and hence may not be injective
 
-Currently we add this independently for each argument, so we also get
-     Couldn't match expected type `a'
-            against inferred type `Dual (Dual a)'
-       NB: `Dual' is a (non-injective) type function
-which is arguably redundant.  But on the other hand, it's probably
-a good idea for the programmer to know the error involves type functions
-so I've left it in for now.  The obvious alternative is to only add
-this NB in the case of matching (T ...) ~ (T ...). 
-     
-
 Warn of loopy local equalities that were dropped.
 
 \begin{code}