Remember to zonk FlatSkols!

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 3bf030d..446bbdb 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -354,8 +354,11 @@ renameDeriv is_boot gen_binds insts
                       | otherwise            = rm_dups (b:acc) bs
 
 
-    rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
-       = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
+    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
+    rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
+       = return ( info { iBinds = NewTypeDerived coi tc }
+                 , mkFVs (map dataConName (tyConDataCons tc)))
+         -- See Note [Newtype deriving and unused constructors]
 
     rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
        =       -- Bring the right type variables into 
@@ -384,6 +387,25 @@ mkGenericBinds is_boot tycl_decls
                -- The predicate tyConHasGenerics finds both of these
 \end{code}
 
+Note [Newtype deriving and unused constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see Trac #1954):
+
+  module Bug(P) where
+  newtype P a = MkP (IO a) deriving Monad
+
+If you compile with -fwarn-unused-binds you do not expect the warning
+"Defined but not used: data consructor MkP". Yet the newtype deriving
+code does not explicitly mention MkP, but it should behave as if you
+had written
+  instance Monad P where
+     return x = MkP (return x)
+     ...etc...
+
+So we want to signal a user of the data constructor 'MkP'.  That's
+what we do in rn_inst_info, and it's the only reason we have the TyCon
+stored in NewTypeDerived.
+
 
 %************************************************************************
 %*                                                                     *
@@ -414,10 +436,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
     all_tydata :: [(LHsType Name, LTyClDecl Name)]
        -- Derived predicate paired with its data type declaration
-    all_tydata = extractTyDataPreds tycl_decls ++
-                [ pd                -- Traverse assoc data families
-                 | L _ (InstDecl _ _ _ ats) <- inst_decls
-                , pd <- extractTyDataPreds ats ]
+    all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
 
     deriv_locs = map (getLoc . snd) all_tydata
                 ++ map getLoc deriv_decls
@@ -529,8 +548,8 @@ When there are no type families, it's quite easy:
     newtype S a = MkS [a]
     -- :CoS :: S  ~ [] -- Eta-reduced
 
-    instance Eq [a] => Eq (S a)        -- by coercion sym (Eq (coMkS a)) : Eq [a] ~ Eq (S a)
-    instance Monad [] => Monad S       -- by coercion sym (Monad coMkS)  : Monad [] ~ Monad S 
+    instance Eq [a] => Eq (S a)        -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
+    instance Monad [] => Monad S       -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S 
 
 When type familes are involved it's trickier:
 
@@ -721,7 +740,7 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy
 -- Generate a sufficiently large set of constraints that typechecking the
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
-inferConstraints tvs cls inst_tys rep_tc rep_tc_args
+inferConstraints _ cls inst_tys rep_tc rep_tc_args
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
     stupid_constraints ++ extra_constraints
     ++ sc_constraints ++ con_arg_constraints
@@ -762,15 +781,20 @@ inferConstraints tvs cls inst_tys rep_tc rep_tc_args
     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
              
-       -- Extra constraints
+       -- Extra Data constraints
        -- The Data class (only) requires that for 
-       --    instance (...) => Data (T a b) 
-       -- then (Data a, Data b) are among the (...) constraints
-       -- Reason: that's what you need to typecheck the method
-       --             dataCast1 f = gcast1 f
+       --    instance (...) => Data (T t1 t2) 
+       -- IF   t1:*, t2:*
+       -- THEN (Data t1, Data t2) are among the (...) constraints
+       -- Reason: when the IF holds, we generate a method
+       --             dataCast2 f = gcast2 f
+       --         and we need the Data constraints to typecheck the method
     extra_constraints 
-      | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs]
-      | otherwise                = []
+      | cls `hasKey` dataClassKey
+      , all (isLiftedTypeKind . typeKind) rep_tc_args 
+      = [mkClassPred cls [ty] | ty <- rep_tc_args]
+      | otherwise 
+      = []
 
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
@@ -953,7 +977,7 @@ cond_functorOK allowFunctions (dflags, rep_tc)
     functions  = ptext (sLit "contains function types")
     wrong_arg  = ptext (sLit "uses the type variable in an argument other than the last")
 
-checkFlag :: DynFlag -> Condition
+checkFlag :: ExtensionFlag -> Condition
 checkFlag flag (dflags, _)
   | dopt flag dflags = Nothing
   | otherwise        = Just why
@@ -1273,6 +1297,7 @@ inferInstanceContexts oflag infer_specs
                 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]  
           ; mapM_ (addErrTc . badDerivedPred) weird_preds      
 
+           ; traceTc (text "TcDeriv" <+> (ppr deriv_rhs $$ ppr theta))
                -- Claim: the result instance declaration is guaranteed valid
                -- Hence no need to call:
                --   checkValidInstance tyvars theta clas inst_tys
@@ -1375,7 +1400,7 @@ genInst :: Bool   -- True <=> standalone deriving
 genInst standalone_deriv oflag spec
   | ds_newtype spec
   = return (InstInfo { iSpec  = mkInstance oflag (ds_theta spec) spec
-                    , iBinds = NewTypeDerived co }, [])
+                    , iBinds = NewTypeDerived co rep_tycon }, [])
 
   | otherwise
   = do { let loc  = getSrcSpan (ds_name spec)