Fix Trac #2334: validity checking for type families

When we deal with a family-instance declaration (TcTyClsDecls.tcFamInstDecl)
we must check the TyCon for validity; for example, that a newtype has exactly
one field.  That is done all-at-once for normal declarations, and had been
forgotten altogether for families.

I also refactored the interface to tcFamInstDecl1 slightly.

A slightly separate matter: if there's an error in family instances
(e.g. overlap) we get a confusing error message cascade if we attempt to
deal with 'deriving' clauses too; this patch bales out earlier in that case.

Another slightly separate matter: standalone deriving for family
instances can legitimately have more specific types, just like normal
data decls. For example

   data instance F [a] = ...
   deriving instance (Eq a, Eq b) => Eq (F [(a,b)])

So tcLookupFamInstExact can a bit more forgiving than it was.

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 3aecc43..b1a2819 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -465,9 +465,29 @@ baleOut :: Message -> TcM (Maybe a)
 baleOut err = do { addErrTc err;  return Nothing }
 \end{code}
 
-Auxiliary lookup wrapper which requires that looked up family instances are
-not type instances.  If called with a vanilla tycon, the old type application
-is simply returned.
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist.  If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+  data instance F () = ... deriving Eq
+  data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+       deriving Eq (F ())
+when there is no data instance F () in scope. 
+
+Note that it's OK to have
+  data instance F [a] = ...
+  deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declrations.
 
 \begin{code}
 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -477,18 +497,14 @@ tcLookupFamInstExact tycon tys
   | otherwise
   = do { maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
-           Nothing                     -> famInstNotFound tycon tys False
-           Just famInst@(_, rep_tys)
-             | not variable_only_subst -> famInstNotFound tycon tys True
-             | otherwise               -> return famInst
-             where
-               tvs                 = map (Type.getTyVar 
-                                             "TcDeriv.tcLookupFamInstExact") 
-                                         rep_tys
-              variable_only_subst  = all Type.isTyVarTy rep_tys &&
-                                     sizeVarSet (mkVarSet tvs) == length tvs
-                                       -- renaming may have no repetitions
+           Nothing      -> famInstNotFound tycon tys
+           Just famInst -> return famInst
        }
+
+famInstNotFound :: TyCon -> [Type] -> TcM a
+famInstNotFound tycon tys 
+  = failWithTc (ptext (sLit "No family instance for")
+                       <+> quotes (pprTypeApp tycon (ppr tycon) tys))
 \end{code}
 
 
@@ -1182,12 +1198,4 @@ badDerivedPred pred
   = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
          ptext (sLit "type variables that are not data type parameters"),
          nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
-
-famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
-famInstNotFound tycon tys notExact
-  = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
-  where
-    msg = ptext $ if notExact
-                 then sLit "No family instance exactly matching"
-                 else sLit "More than one family instance for"
 \end{code}

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 203ffe4..a2d8242 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -187,6 +187,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 -- decl, so it needs to know about all the instances possible
                 -- NB: class instance declarations can contain derivings as
                 --     part of associated data type declarations
+        failIfErrsM            -- If the addInsts stuff gave any errors, don't
+                               -- try the deriving stuff, becuase that may give
+                               -- more errors still
        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
                                                       deriv_decls
        ; addInsts deriv_inst_info   $ do {

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index ba17fdd..35c7470 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -259,11 +259,14 @@ tcFamInstDecl (L loc decl)
        ; checkTc type_families $ badFamInstDecl (tcdLName decl)
        ; checkTc (not is_boot) $ badBootFamInstDeclErr
 
-        -- perform kind and type checking
-       ; tcFamInstDecl1 decl
+        -- Perform kind and type checking
+       ; tc <- tcFamInstDecl1 decl
+       ; checkValidTyCon tc    -- Remember to check validity;
+                               -- no recursion to worry about here
+       ; return (Just (ATyCon tc))
        }
 
-tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 
   -- "type instance"
 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
@@ -292,10 +295,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
 
          -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name loc
-       ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
-                                (Just (family, t_typats))
-
-       ; return $ Just (ATyCon tycon)
+       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
+                       (Just (family, t_typats))
        }}
 
   -- "newtype instance" and "data instance"
@@ -338,7 +339,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
          -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name loc
        ; let ex_ok = True      -- Existentials ok for type families!
-       ; tycon <- fixM (\ tycon -> do 
+       ; fixM (\ tycon -> do 
             { data_cons <- mapM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs))
                                  k_cons
             ; tc_rhs <-
@@ -354,9 +355,6 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                  -- dependency.  (2) They are always valid loop breakers as
                  -- they involve a coercion.
             })
-
-         -- construct result
-       ; return $ Just (ATyCon tycon)
        }}
        where
         h98_syntax = case cons of      -- All constructors have same shape