type EarlyDerivSpec = Either DerivSpec DerivSpec
-- Left ds => the context for the instance should be inferred
- -- (ds_theta is required)
- -- Right ds => the context for the instance is supplied by the programmer
+ -- In this case ds_theta is the list of all the
+ -- constraints needed, such as (Eq [a], Eq a)
+ -- The inference process is to reduce this to a
+ -- simpler form (e.g. Eq a)
+ --
+ -- Right ds => the exact context for the instance is supplied
+ -- by the programmer; it is ds_theta
pprDerivSpec :: DerivSpec -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(See also Trac #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+
The 'tys' here come from the partial application in the deriving
clause. The last arg is the new instance type.
-> TcM [EarlyDerivSpec]
makeDerivSpecs tycl_decls inst_decls deriv_decls
- = do { eqns1 <- mapM deriveTyData $
+ = do { eqns1 <- mapAndRecoverM deriveTyData $
extractTyDataPreds tycl_decls ++
[ pd -- traverse assoc data families
| L _ (InstDecl _ _ _ ats) <- inst_decls
, pd <- extractTyDataPreds ats ]
- ; eqns2 <- mapM deriveStandalone deriv_decls
+ ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
; return (catMaybes (eqns1 ++ eqns2)) }
where
extractTyDataPreds decls =
------------------------------------------------------------------
mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
- -> Maybe ThetaType -- Just => context supplied
- -- Nothing => context inferred
+ -> Maybe ThetaType -- Just => context supplied (standalone deriving)
+ -- Nothing => context inferred (deriving on data decl)
-> TcRn (Maybe EarlyDerivSpec)
mkEqnHelp orig tvs cls cls_tys tc_app mtheta
| Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
- = do { -- Make tc_app saturated, because that's what the
- -- mkDataTypeEqn things expect
- -- It might not be saturated in the standalone deriving case
- -- derive instance Monad (T a)
- let extra_tvs = dropList tc_args (tyConTyVars tycon)
- full_tc_args = tc_args ++ mkTyVarTys extra_tvs
- full_tvs = tvs ++ extra_tvs
-
- ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_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
- mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys
- tycon full_tc_args rep_tc rep_tc_args mtheta
+ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args mtheta
else
mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
- full_tvs cls cls_tys
- tycon full_tc_args rep_tc rep_tc_args mtheta }
+ tvs cls cls_tys
+ 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")))
= ASSERT( null cls_tys )
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-mk_data_eqn :: InstOrigin -> [TyVar] -> Class
- -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
- -> TcM (Maybe EarlyDerivSpec)
+mk_data_eqn, mk_typeable_eqn
+ :: InstOrigin -> [TyVar] -> Class
+ -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+ -> TcM (Maybe EarlyDerivSpec)
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
- | cls `hasKey` typeableClassKey
- = -- The Typeable class is special in several ways
- -- data T a b = ... deriving( Typeable )
- -- gives
- -- instance Typeable2 T where ...
- -- Notice that:
- -- 1. There are no constraints in the instance
- -- 2. There are no type variables either
- -- 3. The actual class we want to generate isn't necessarily
- -- Typeable; it depends on the arity of the type
- do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
- ; dfun_name <- new_dfun_name real_clas tycon
- ; loc <- getSrcSpanM
- ; return (Just $ Right $
- DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
- , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []]
- , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
+ | getName cls `elem` typeableClassNames
+ = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
| otherwise
= do { dfun_name <- new_dfun_name cls tycon
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 )
+ -- gives
+ -- instance Typeable2 T where ...
+ -- Notice that:
+ -- 1. There are no constraints in the instance
+ -- 2. There are no type variables either
+ -- 3. The actual class we want to generate isn't necessarily
+ -- 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"))
+ ; 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")
+ <> int (tyConArity tycon) <+> ppr tycon <> rparen)
+ ; dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; return (Just $ Right $
+ DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
+ , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
+ , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
+
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
| notNull cls_tys
= Just ty_args_why -- e.g. deriving( Foo s )
| otherwise
- = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
- [] -> Just (non_std_why cls)
- [cond] -> cond (mayDeriveDataTypeable, rep_tc)
- _other -> pprPanic "checkSideConditions" (ppr cls)
+ = case sideConditions cls of
+ 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 :: Class -> SDoc
-non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
-
-sideConditions :: [(Unique, Condition)]
-sideConditions
- = [ (eqClassKey, cond_std),
- (ordClassKey, cond_std),
- (readClassKey, cond_std),
- (showClassKey, cond_std),
- (enumClassKey, cond_std `andCond` cond_isEnumeration),
- (ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
- (boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
- (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
- (dataClassKey, cond_mayDeriveDataTypeable `andCond` cond_std)
- ]
+ non_std_why = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
+
+sideConditions :: Class -> Maybe Condition
+sideConditions cls
+ | cls_key == eqClassKey = Just cond_std
+ | cls_key == ordClassKey = Just cond_std
+ | cls_key == readClassKey = Just cond_std
+ | cls_key == showClassKey = Just cond_std
+ | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | cls_key == ixClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+ | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+ | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+ | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+ | otherwise = Nothing
+ where
+ cls_key = getUnique cls
type Condition = (Bool, TyCon) -> Maybe SDoc
-- Bool is whether or not we are allowed to derive Data and Typeable
| mayDeriveDataTypeable = Nothing
| otherwise = Just why
where
- why = ptext SLIT("You need -fglasgow-exts 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
-- 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 ...
+
%************************************************************************
%* *
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 = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
+standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for"))
+ 2 (quotes (ppr ty))
derivInstCtxt :: Class -> [Type] -> Message
derivInstCtxt clas inst_tys
projects / ghc-hetmet.git / blobdiff