X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=446bbdbf3dfa60945d6a979274cfecf4e7ec10c0;hb=9d193eceb5f287ac3dfa90b40e22d9c992cf9f66;hp=3466cbfab1e9df61aa0bfe28f4af51fe0e9ecc4d;hpb=895eccb09f195beefeba9d3c59d7dfa557c6f7d1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 3466cbf..446bbdb 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -337,7 +337,7 @@ renameDeriv is_boot gen_binds insts ; let aux_binds = listToBag $ map (genAuxBind loc) $ rm_dups [] $ concat deriv_aux_binds ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds []) - ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs) + ; let aux_names = collectHsValBinders rn_aux_lhs ; bindLocalNames aux_names $ do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_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 @@ -440,8 +459,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) <+> text "tvs:" <+> ppr tvs <+> text "theta:" <+> ppr theta <+> text "tau:" <+> ppr tau) - ; (cls, inst_tys) <- checkValidInstHead tau - ; checkValidInstance tvs theta cls inst_tys + ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau -- C.f. TcInstDcls.tcLocalInstDecl1 ; let cls_tys = take (length inst_tys - 1) inst_tys @@ -530,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: @@ -722,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 @@ -763,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 @@ -954,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 @@ -966,13 +989,25 @@ checkFlag flag (dflags, _) other -> pprPanic "checkFlag" (ppr other) std_class_via_iso :: Class -> Bool -std_class_via_iso clas -- These standard classes can be derived for a newtype - -- using the isomorphism trick *even if no -fglasgow-exts* +-- These standard classes can be derived for a newtype +-- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_iso clas = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] -- Not Read/Show because they respect the type -- Not Enum, because newtypes are never in Enum +non_iso_class :: Class -> Bool +-- *Never* derive Read,Show,Typeable,Data by isomorphism, +-- even with -XGeneralizedNewtypeDeriving +non_iso_class cls + = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++ + typeableClassKeys) + +typeableClassKeys :: [Unique] +typeableClassKeys = map getUnique typeableClassNames + new_dfun_name :: Class -> TyCon -> TcM Name new_dfun_name clas tycon -- Just a simple wrapper = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon @@ -1038,18 +1073,21 @@ mkNewTypeEqn orig dflags tvs | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of - CanDerive -> go_for_it -- Use the standard H98 method - DerivableClassError msg -> bale_out msg -- Error with standard class + CanDerive -> go_for_it -- Use the standard H98 method + DerivableClassError msg -- Error with standard class + | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd) + | otherwise -> bale_out msg NonDerivableClass -- Must use newtype deriving - | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving - | otherwise -> bale_out non_std_err -- Try newtype deriving! + | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving + | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving! + | otherwise -> bale_out non_std where newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) - non_std_err = nonStdErr cls $$ - ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") + non_std = nonStdErr cls + suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) @@ -1133,10 +1171,6 @@ mkNewTypeEqn orig dflags tvs && ats_ok -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - -- Never derive Read,Show,Typeable,Data by isomorphism - non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++ - typeableClassNames) - arity_ok = length cls_tys + 1 == classArity cls -- Well kinded; eg not: newtype T ... deriving( ST ) -- because ST needs *2* type params @@ -1263,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 @@ -1365,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)