Reject newtypes with strictness annotations; fixes read008

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index f9be61f..4e1a065 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -47,6 +47,8 @@ import Util
 import ListSetOps
 import Outputable
 import Bag
+
+import Monad (unless)
 \end{code}
 
 %************************************************************************
@@ -395,11 +397,14 @@ mkEqnHelp orig tvs cls cls_tys tc_app
              full_tc_args = tc_args ++ mkTyVarTys extra_tvs
              full_tvs = tvs ++ extra_tvs
                
-       ; (rep_tc, rep_tc_args) <- tcLookupFamInst tycon full_tc_args
+       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
 
        ; gla_exts <- doptM Opt_GlasgowExts
        ; overlap_flag <- getOverlapFlag
-       ; if isDataTyCon tycon then
+
+          -- Be careful to test rep_tc here: in the case of families, we want
+          -- to check the instance tycon, not the family tycon
+       ; if isDataTyCon rep_tc then
                mkDataTypeEqn orig gla_exts full_tvs cls cls_tys 
                              tycon full_tc_args rep_tc rep_tc_args
          else
@@ -412,6 +417,27 @@ mkEqnHelp orig tvs cls cls_tys tc_app
 baleOut err = addErrTc err >> returnM (Nothing, Nothing) 
 \end{code}
 
+Auxiliary lookup wrapper which requires that looked up family instances are
+not type instances.
+
+\begin{code}
+tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInstExact tycon tys
+  = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys
+       ; let { tvs                   = map (Type.getTyVar 
+                                               "TcDeriv.tcLookupFamInstExact") 
+                                           tys
+            ; variable_only_subst = all Type.isTyVarTy rep_tys &&
+                                    sizeVarSet (mkVarSet tvs) == length tvs
+                                       -- renaming may have no repetitions
+             }
+       ; unless variable_only_subst $
+           famInstNotFound tycon tys [result]
+       ; return result
+       }
+       
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -578,7 +604,7 @@ std_class_via_iso clas      -- These standard classes can be derived for a newtype
 
 
 new_dfun_name clas tycon       -- Just a simple wrapper
-  = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
+  = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
        -- The type passed to newDFunName is only used to generate
        -- a suitable string; hence the empty type arg list
 \end{code}
@@ -977,7 +1003,7 @@ genInst spec
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
-        ; (tycon, _) <- tcLookupFamInst visible_tycon tyArgs
+        ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
        ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
 
        -- Bring the right type variables into 
@@ -1122,4 +1148,4 @@ badDerivedPred pred
          nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
 \end{code}
 
- 
\ No newline at end of file
+