FIX Trac #1935: generate superclass constraints for derived classes

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 445a1f4..e79318b 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -431,11 +431,22 @@ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
-  = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+  = do {
+       -- For standalone deriving (mtheta /= Nothing), 
+       -- check that all the data constructors are in scope
+       -- By this time we know that the thing is algebraic
+       --      because we've called checkInstHead in derivingStandalone
+         rdr_env <- getGlobalRdrEnv
+       ; let hidden_data_cons = filter not_in_scope (tyConDataCons tycon)
+             not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
+       ; checkTc (isNothing mtheta || null hidden_data_cons) 
+                 (derivingHiddenErr tycon)
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
+       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+
           -- 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
@@ -519,21 +530,24 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
+                       -- See Note [Superclasses of derived instance]
+             sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+                                         (classSCTheta cls)
+             inst_tys =  [mkTyConApp tycon tc_args]
+
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
-             all_constraints = stupid_constraints ++ ordinary_constraints
-                        -- see Note [Data decl contexts] above
+             all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
-                       , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
+                       , ds_cls = cls, ds_tys = inst_tys
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
-
 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
        -- The Typeable class is special in several ways
        --        data T a b = ... deriving( Typeable )
@@ -684,6 +698,30 @@ new_dfun_name clas tycon   -- Just a simple wrapper
        -- a suitable string; hence the empty type arg list
 \end{code}
 
+Note [Superclasses of derived instance] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+       data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is 
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint 
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+       data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+       instance Typable a => Data (T a) where ...
+
 
 %************************************************************************
 %*                                                                     *
@@ -1125,6 +1163,11 @@ derivingThingErr clas tys ty why
   where
     pred = mkClassPred clas (tys ++ [ty])
 
+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (ptext SLIT("The data constructors of") <+> quotes (ppr tc) <+> ptext SLIT("are not all in scope"))
+       2 (ptext SLIT("so you cannot derive an instance for it"))
+
 standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for")) 
                       2 (quotes (ppr ty))