X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=03638b100d5819a1ada2e050afb4ee38d2bd274e;hb=94696a96b799ae942e8dfe4edb2c74268b9fccee;hp=f3224c8a44a47595a701bfb680bc275420f3850a;hpb=219f900f4e518e8158807cdda6fdec8331f701f0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index f3224c8..03638b1 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -46,6 +46,7 @@ import SrcLoc import Util import ListSetOps import Outputable +import FastString import Bag \end{code} @@ -265,7 +266,7 @@ tcDeriving :: [LTyClDecl Name] -- All type constructors HsValBinds Name) -- Extra generated top-level bindings tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (returnM ([], emptyValBindsOut)) $ + = recoverM (return ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls @@ -286,8 +287,8 @@ tcDeriving tycl_decls inst_decls deriv_decls ; let inst_info = insts1 ++ insts2 ; dflags <- getDOpts - ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds)) + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds)) ; return (inst_info, rn_binds) } where @@ -392,9 +393,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) <+> text "theta:" <+> ppr theta <+> text "tau:" <+> ppr tau) ; (cls, inst_tys) <- checkValidInstHead tau + ; checkValidInstance tvs theta cls inst_tys + -- C.f. TcInstDcls.tcLocalInstDecl1 + ; let cls_tys = take (length inst_tys - 1) inst_tys inst_ty = last inst_tys - ; traceTc (text "standalone deriving;" <+> text "class:" <+> ppr cls <+> text "class types:" <+> ppr cls_tys @@ -431,24 +434,24 @@ 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 { + , isAlgTyCon tycon -- Check for functions, primitive types etc + = do { (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 + -- 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) + ; rdr_env <- getGlobalRdrEnv + ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc) + not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) + ; checkTc (isNothing mtheta || not 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 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta @@ -458,15 +461,35 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta tycon tc_args rep_tc rep_tc_args mtheta } | otherwise = baleOut (derivingThingErr cls cls_tys tc_app - (ptext SLIT("Last argument of the instance must be a type application"))) + (ptext (sLit "The last argument of the instance must be a data or newtype application"))) 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]) @@ -476,18 +499,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} @@ -560,13 +579,13 @@ mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta -- Typeable; it depends on the arity of the type | isNothing mtheta -- deriving on a data type decl = do { checkTc (cls `hasKey` typeableClassKey) - (ptext SLIT("Use deriving( Typeable ) on a data type declaration")) + (ptext (sLit "Use deriving( Typeable ) on a data type declaration")) ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) } | otherwise -- standaone deriving = do { checkTc (null tc_args) - (ptext SLIT("Derived typeable instance must be of form (Typeable") + (ptext (sLit "Derived typeable instance must be of form (Typeable") <> int (tyConArity tycon) <+> ppr tycon <> rparen) ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM @@ -592,8 +611,8 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc Just cond -> cond (mayDeriveDataTypeable, rep_tc) Nothing -> Just non_std_why where - ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class") - non_std_why = quotes (ppr cls) <+> ptext SLIT("is not a derivable class") + ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") + non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class") sideConditions :: Class -> Maybe Condition sideConditions cls @@ -622,7 +641,7 @@ orCond c1 c2 tc Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails Nothing -> Nothing - Just y -> Just (x $$ ptext SLIT(" and") $$ y) + Just y -> Just (x $$ ptext (sLit " and") $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -638,9 +657,9 @@ cond_std (_, rep_tc) where data_cons = tyConDataCons rep_tc no_cons_why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has no data constructors") + ptext (sLit "has no data constructors") existential_why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has non-Haskell-98 constructor(s)") + ptext (sLit "has non-Haskell-98 constructor(s)") cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc) @@ -648,7 +667,7 @@ cond_isEnumeration (_, rep_tc) | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has non-nullary constructors") + ptext (sLit "has non-nullary constructors") cond_isProduct :: Condition cond_isProduct (_, rep_tc) @@ -656,7 +675,7 @@ cond_isProduct (_, rep_tc) | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has more than one constructor") + ptext (sLit "has more than one constructor") cond_typeableOK :: Condition -- OK for Typeable class @@ -670,18 +689,18 @@ cond_typeableOK (_, rep_tc) | otherwise = Nothing where too_many = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has too many arguments") + ptext (sLit "has too many arguments") bad_kind = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has arguments of kind other than `*'") + ptext (sLit "has arguments of kind other than `*'") fam_inst = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("is a type family") + ptext (sLit "is a type family") cond_mayDeriveDataTypeable :: Condition cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _) | mayDeriveDataTypeable = Nothing | otherwise = Just why where - why = ptext SLIT("You need -XDeriveDataTypeable to derive an instance for this class") + why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class") std_class_via_iso :: Class -> Bool std_class_via_iso clas -- These standard classes can be derived for a newtype @@ -758,7 +777,7 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon std_err = derivingThingErr cls cls_tys tc_app $ vcat [fromJust mb_std_err, - ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")] + 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, ...) @@ -892,19 +911,19 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs -- arguments must be type variables (not more complex indexes) cant_derive_err = derivingThingErr cls cls_tys tc_app - (vcat [ptext SLIT("even with cunning newtype deriving:"), + (vcat [ptext (sLit "even with cunning newtype deriving:"), if isRecursiveTyCon tycon then - ptext SLIT("the newtype may be recursive") + ptext (sLit "the newtype may be recursive") else empty, if not right_arity then - quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1") + quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") else empty, if not (n_tyargs_to_keep >= 0) then - ptext SLIT("the type constructor has wrong kind") + ptext (sLit "the type constructor has wrong kind") else if not (n_args_to_keep >= 0) then - ptext SLIT("the representation type has wrong kind") + ptext (sLit "the representation type has wrong kind") else if not eta_ok then - ptext SLIT("the eta-reduction property does not hold") + ptext (sLit "the eta-reduction property does not hold") else empty ]) \end{code} @@ -954,7 +973,7 @@ inferInstanceContexts oflag infer_specs iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec] iterate_deriv n current_solns | n > 20 -- Looks as if we are in an infinite loop - -- This can happen if we have -fallow-undecidable-instances + -- This can happen if we have -XUndecidableInstances -- (See TcSimplify.tcSimplifyDeriv.) = pprPanic "solveDerivEqns: probable loop" (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) @@ -1157,7 +1176,7 @@ genDerivBinds clas fix_env tycon \begin{code} derivingThingErr :: Class -> [Type] -> Type -> Message -> Message derivingThingErr clas tys ty why - = sep [hsep [ptext SLIT("Can't make a derived instance of"), + = sep [hsep [ptext (sLit "Can't make a derived instance of"), quotes (ppr pred)], nest 2 (parens why)] where @@ -1165,28 +1184,20 @@ derivingThingErr clas tys ty why 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")) + = 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")) +standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) derivInstCtxt :: Class -> [Type] -> Message derivInstCtxt clas inst_tys - = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys) + = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) badDerivedPred :: PredType -> Message 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") + = 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)] \end{code}