Fix Trac #2334: validity checking for type families

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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index ee62c0e..d2f8242 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -33,6 +33,7 @@ import {-# SOURCE #-} TcUnify( unifyType )
 import HsSyn
 
 import TcRnMonad
 import HsSyn
 
 import TcRnMonad

+import TcHsSyn ( hsLPatType )

 import Inst
 import TcEnv
 import InstEnv
 import Inst
 import TcEnv
 import InstEnv

@@ -40,6 +41,7 @@ import TcType
 import TcMType
 import TcIface
 import TcTyFuns
 import TcMType
 import TcIface
 import TcTyFuns

+import DsUtils -- Big-tuple functions

 import TypeRep
 import Var
 import Name
 import TypeRep
 import Var
 import Name

@@ -1006,16 +1008,15 @@ makeImplicationBind loc all_tvs
              (eq_irreds, dict_irreds) = partition isEqInst irreds
               n_dict_irreds = length dict_irreds
              dict_irred_ids = map instToId dict_irreds
              (eq_irreds, dict_irreds) = partition isEqInst irreds
               n_dict_irreds = length dict_irreds
              dict_irred_ids = map instToId dict_irreds

-             tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
-             pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
+             lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)

              rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
              co  = mkWpApps (map instToId dict_givens)
                    <.> mkWpTyApps eq_tyvar_cos
                    <.> mkWpTyApps (mkTyVarTys all_tvs)
              bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs
              rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
              co  = mkWpApps (map instToId dict_givens)
                    <.> mkWpTyApps eq_tyvar_cos
                    <.> mkWpTyApps (mkTyVarTys all_tvs)
              bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs

-                  | otherwise        = PatBind { pat_lhs = L span pat, 
+                  | otherwise        = PatBind { pat_lhs = lpat, 

                                                  pat_rhs = unguardedGRHSs rhs, 
                                                  pat_rhs = unguardedGRHSs rhs, 

-                                                 pat_rhs_ty = tup_ty,
+                                                 pat_rhs_ty = hsLPatType lpat,

                                                  bind_fvs = placeHolderNames }
        ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
        ; return ([implic_inst], unitBag (L span bind)) 
                                                  bind_fvs = placeHolderNames }
        ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
        ; return ([implic_inst], unitBag (L span bind)) 

@@ -2187,16 +2188,15 @@ reduceImplication env
                      <.> WpLet (binds `unionBags` bind)
                wrap_inline | null dict_ids = idHsWrapper
                            | otherwise     = WpInline
                      <.> WpLet (binds `unionBags` bind)
                wrap_inline | null dict_ids = idHsWrapper
                            | otherwise     = WpInline

-               rhs = mkHsWrap co payload
+               rhs = mkLHsWrap co payload

                loc = instLocSpan inst_loc
                loc = instLocSpan inst_loc

-               payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
-                       | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
+               payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)

 
        
        ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                         ppr simpler_implic_insts,
                         text "->" <+> ppr rhs])
 
        
        ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                         ppr simpler_implic_insts,
                         text "->" <+> ppr rhs])

-       ; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
+       ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),

                  simpler_implic_insts)
        } 
     }
                  simpler_implic_insts)
        } 
     }

@@ -2237,12 +2237,29 @@ We can satisfy the (C Int) from the superclass of D, so we don't want
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 

+One more example: the constraint
+       class C a => D a b
+       instance (C a, E c) => E (a,c)
+
+       constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'.  But 
+in fact it can, because solving the (E (Int,c)) constraint needs 
+dictionaries
+       C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+

 Note [Pruning the givens in an implication constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are about to form the implication constraint
        forall tvs.  Eq a => Ord b
 The (Eq a) cannot contribute to the (Ord b), because it has no access to
 the type variable 'b'.  So we could filter out the (Eq a) from the givens.
 Note [Pruning the givens in an implication constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are about to form the implication constraint
        forall tvs.  Eq a => Ord b
 The (Eq a) cannot contribute to the (Ord b), because it has no access to
 the type variable 'b'.  So we could filter out the (Eq a) from the givens.

+But BE CAREFUL of the examples above in [Freeness and implications].

 
 Doing so would be a bit tidier, but all the implication constraints get
 simplified away by the optimiser, so it's no great win.   So I don't take
 
 Doing so would be a bit tidier, but all the implication constraints get
 simplified away by the optimiser, so it's no great win.   So I don't take