Add tuple sections as a new feature

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 738d36f..b03870e 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -290,7 +290,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; checkValidTypeInst t_typats t_rhs
 
          -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
                        (typeKind t_rhs) (Just (family, t_typats))
        }}
@@ -334,7 +334,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                 newtypeConError tc_name (length k_cons)
 
          -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; let ex_ok = True      -- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do 
             { let orig_res_ty = mkTyConApp fam_tycon t_typats
@@ -1257,12 +1257,19 @@ mkRecSelBind (tycon, sel_name)
     -- Add catch-all default case unless the case is exhaustive
     -- We do this explicitly so that we get a nice error message that
     -- mentions this particular record selector
-    deflt | length cons_w_field == length all_cons = []
+    deflt | not (any is_unused all_cons) = []
          | otherwise = [mkSimpleMatch [nlWildPat] 
                            (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
                                     (nlHsLit msg_lit))]
 
-    unit_rhs = L loc $ ExplicitTuple [] Boxed
+       -- Do not add a default case unless there are unmatched
+       -- constructors.  We must take account of GADTs, else we
+       -- get overlap warning messages from the pattern-match checker
+    is_unused con = not (con `elem` cons_w_field 
+                        || dataConCannotMatch inst_tys con)
+    inst_tys = tyConAppArgs data_ty
+
+    unit_rhs = mkLHsTupleExpr []
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)