%************************************************************************
\begin{code}
-tcDeriving :: [LTyClDecl Name] -- All type constructors
+tcDeriving :: [LTyClDecl Name] -- All type constructors
+ -> [LInstDecl Name] -- All instance declarations
-> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM ([InstInfo], -- The generated "instance decls"
HsValBinds Name) -- Extra generated top-level bindings
-tcDeriving tycl_decls deriv_decls
+tcDeriving tycl_decls inst_decls deriv_decls
= recoverM (returnM ([], emptyValBindsOut)) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls deriv_decls
+ ; (ordinary_eqns, newtype_inst_info)
+ <- makeDerivEqns tycl_decls inst_decls deriv_decls
; (ordinary_inst_info, deriv_binds)
<- extendLocalInstEnv (map iSpec newtype_inst_info) $
; gen_binds <- mkGenericBinds tycl_decls
-- Rename these extra bindings, discarding warnings about unused bindings etc
- -- Set -fglasgow exts so that we can have type signatures in patterns,
- -- which is used in the generic binds
+ -- Type signatures in patterns are used in the generic binds
; rn_binds
- <- discardWarnings $ setOptM Opt_GlasgowExts $ do
+ <- discardWarnings $
+ setOptM Opt_PatternSignatures $
+ do
{ (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds [])
; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
\begin{code}
makeDerivEqns :: [LTyClDecl Name]
+ -> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
-makeDerivEqns tycl_decls deriv_decls
+makeDerivEqns tycl_decls inst_decls deriv_decls
= do { eqns1 <- mapM deriveTyData $
- [ (p,d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- tycl_decls
- , p <- preds ]
+ extractTyDataPreds tycl_decls ++
+ [ pd -- traverse assoc data families
+ | L _ (InstDecl _ _ _ ats) <- inst_decls
+ , pd <- extractTyDataPreds ats ]
; eqns2 <- mapM deriveStandalone deriv_decls
; return ([eqn | (Just eqn, _) <- eqns1 ++ eqns2],
[inst | (_, Just inst) <- eqns1 ++ eqns2]) }
+ where
+ extractTyDataPreds decls =
+ [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo)
; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
- ; gla_exts <- doptM Opt_GlasgowExts
+ ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
+ ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
; overlap_flag <- getOverlapFlag
-- 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 gla_exts full_tvs cls cls_tys
+ mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys
tycon full_tc_args rep_tc rep_tc_args
else
- mkNewTypeEqn orig gla_exts overlap_flag full_tvs cls cls_tys
+ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag
+ full_tvs cls cls_tys
tycon full_tc_args rep_tc rep_tc_args }
| otherwise
= baleOut (derivingThingErr cls cls_tys tc_app
%************************************************************************
\begin{code}
-mkDataTypeEqn orig gla_exts tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
- | Just err <- checkSideConditions gla_exts cls cls_tys rep_tc
+mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args
+ | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
-- NB: pass the *representation* tycon to checkSideConditions
= baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
-- family tycon (with indexes) in error messages.
checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
-checkSideConditions gla_exts cls cls_tys rep_tc
+checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
| 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 (gla_exts, rep_tc)
+ [cond] -> cond (mayDeriveDataTypeable, rep_tc)
other -> pprPanic "checkSideConditions" (ppr cls)
where
ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
(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_glaExts `andCond` cond_typeableOK),
- (dataClassKey, cond_glaExts `andCond` cond_std)
+ (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
+ (dataClassKey, cond_mayDeriveDataTypeable `andCond` cond_std)
]
type Condition = (Bool, TyCon) -> Maybe SDoc
- -- Bool is gla-exts flag
+ -- Bool is whether or not we are allowed to derive Data and Typeable
-- TyCon is the *representation* tycon if the
-- data type is an indexed one
-- Nothing => OK
Just x -> Just x -- c1 fails
cond_std :: Condition
-cond_std (gla_exts, rep_tc)
+cond_std (_, rep_tc)
| any (not . isVanillaDataCon) data_cons = Just existential_why
| null data_cons = Just no_cons_why
| otherwise = Nothing
ptext SLIT("has non-Haskell-98 constructor(s)")
cond_isEnumeration :: Condition
-cond_isEnumeration (gla_exts, rep_tc)
+cond_isEnumeration (_, rep_tc)
| isEnumerationTyCon rep_tc = Nothing
| otherwise = Just why
where
ptext SLIT("has non-nullary constructors")
cond_isProduct :: Condition
-cond_isProduct (gla_exts, rep_tc)
+cond_isProduct (_, rep_tc)
| isProductTyCon rep_tc = Nothing
| otherwise = Just why
where
-- OK for Typeable class
-- Currently: (a) args all of kind *
-- (b) 7 or fewer args
-cond_typeableOK (gla_exts, rep_tc)
+cond_typeableOK (_, rep_tc)
| tyConArity rep_tc > 7 = Just too_many
| not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
= Just bad_kind
fam_inst = quotes (pprSourceTyCon rep_tc) <+>
ptext SLIT("is a type family")
-cond_glaExts :: Condition
-cond_glaExts (gla_exts, _rep_tc) | gla_exts = Nothing
- | otherwise = Just why
+cond_mayDeriveDataTypeable :: Condition
+cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
+ | mayDeriveDataTypeable = Nothing
+ | otherwise = Just why
where
why = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
%************************************************************************
\begin{code}
-mkNewTypeEqn orig gla_exts overlap_flag tvs cls cls_tys
+mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> OverlapFlag -> [Var] -> Class
+ -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> TcRn (Maybe DerivEqn, Maybe InstInfo)
+mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs cls cls_tys
tycon tc_args
rep_tycon rep_tc_args
- | can_derive_via_isomorphism && (gla_exts || std_class_via_iso cls)
+ | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
= do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
; -- Go ahead and use the isomorphism
dfun_name <- new_dfun_name cls tycon
; return (Just eqn, Nothing) }
-- Otherwise we can't derive
- | gla_exts = baleOut cant_derive_err -- Too hard
+ | newtype_deriving = baleOut cant_derive_err -- Too hard
| otherwise = baleOut std_err -- Just complain about being a non-std instance
where
- mb_std_err = checkSideConditions gla_exts cls cls_tys rep_tycon
+ 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 -fglasgow-exts 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, ...)
projects / ghc-hetmet.git / blobdiff