+------------------------------------------------------------------
+deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)
+-- Standalone deriving declarations
+-- e.g. deriving instance show a => Show (T a)
+-- Rather like tcLocalInstDecl
+deriveStandalone (L loc (DerivDecl deriv_ty))
+ = setSrcSpan loc $
+ addErrCtxt (standaloneCtxt deriv_ty) $
+ do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
+ ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
+ ; traceTc (text "standalone deriving;"
+ <+> text "tvs:" <+> ppr tvs
+ <+> text "theta:" <+> ppr theta
+ <+> text "tau:" <+> ppr tau)
+ ; (cls, inst_tys) <- checkValidInstHead tau
+ ; 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
+ <+> text "type:" <+> ppr inst_ty)
+ ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
+ (Just theta) }
+
+------------------------------------------------------------------
+deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
+deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
+ tcdTyVars = tv_names,
+ tcdTyPats = ty_pats }))
+ = setSrcSpan loc $
+ tcAddDeclCtxt decl $
+ do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
+ hs_app = nlHsTyConApp tycon_name hs_ty_args
+ -- We get kinding info for the tyvars by typechecking (T a b)
+ -- Hence forming a tycon application and then dis-assembling it
+ ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
+ ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
+ -- the type variables for the type constructor
+ do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
+ -- The "deriv_pred" is a LHsType to take account of the fact that for
+ -- newtype deriving we allow deriving (forall a. C [a]).
+ ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
+
+deriveTyData _other
+ = panic "derivTyData" -- Caller ensures that only TyData can happen
+
+------------------------------------------------------------------
+mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
+ -> 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 {
+ -- 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 tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args mtheta
+ else
+ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
+ 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")))
+
+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.
+
+\begin{code}
+tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInstExact tycon tys
+ | not (isOpenTyCon tycon)
+ = return (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
+ }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Deriving data types
+%* *
+%************************************************************************
+
+\begin{code}
+mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
+ -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType
+ -> TcRn (Maybe EarlyDerivSpec) -- Return 'Nothing' if error
+
+mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args mtheta
+ | 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)
+
+ | otherwise
+ = ASSERT( null cls_tys )
+ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+
+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
+ | 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
+ ; loc <- getSrcSpanM
+ ; let ordinary_constraints
+ = [ mkClassPred cls [arg_ty]
+ | data_con <- tyConDataCons rep_tc,
+ arg_ty <- ASSERT( isVanillaDataCon data_con )
+ 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 ++ sc_constraints ++ ordinary_constraints
+
+ spec = DS { ds_loc = loc, ds_orig = orig
+ , ds_name = dfun_name, ds_tvs = tvs
+ , 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
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
+checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
+ | notNull cls_tys
+ = Just ty_args_why -- e.g. deriving( Foo s )
+ | otherwise
+ = 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 = 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
+ -- TyCon is the *representation* tycon if the
+ -- data type is an indexed one
+ -- Nothing => OK
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 tc
+ = case c1 tc of
+ Nothing -> Nothing -- c1 succeeds
+ Just x -> case c2 tc of -- c1 fails
+ Nothing -> Nothing
+ Just y -> Just (x $$ ptext SLIT(" and") $$ y)
+ -- Both fail
+
+andCond :: Condition -> Condition -> Condition
+andCond c1 c2 tc = case c1 tc of
+ Nothing -> c2 tc -- c1 succeeds
+ Just x -> Just x -- c1 fails
+
+cond_std :: Condition
+cond_std (_, rep_tc)
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
+ where
+ data_cons = tyConDataCons rep_tc
+ no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has no data constructors")
+ existential_why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has non-Haskell-98 constructor(s)")
+
+cond_isEnumeration :: Condition
+cond_isEnumeration (_, rep_tc)
+ | isEnumerationTyCon rep_tc = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has non-nullary constructors")
+
+cond_isProduct :: Condition
+cond_isProduct (_, rep_tc)
+ | isProductTyCon rep_tc = Nothing
+ | otherwise = Just why
+ where
+ why = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has more than one constructor")
+
+cond_typeableOK :: Condition
+-- OK for Typeable class
+-- Currently: (a) args all of kind *
+-- (b) 7 or fewer args
+cond_typeableOK (_, rep_tc)
+ | tyConArity rep_tc > 7 = Just too_many
+ | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
+ = Just bad_kind
+ | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
+ | otherwise = Nothing
+ where
+ too_many = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has too many arguments")
+ bad_kind = quotes (pprSourceTyCon rep_tc) <+>
+ ptext SLIT("has arguments of kind other than `*'")
+ fam_inst = quotes (pprSourceTyCon rep_tc) <+>
+ 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")
+
+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*
+ = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+ -- Not Read/Show because they respect the type
+ -- Not Enum, because newtypes are never in Enum
+
+
+new_dfun_name :: Class -> TyCon -> TcM Name
+new_dfun_name clas tycon -- Just a simple wrapper
+ = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
+ -- The type passed to newDFunName is only used to generate
+ -- 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 ...
+
+
+%************************************************************************
+%* *
+ Deriving newtypes
+%* *
+%************************************************************************
+
+\begin{code}
+mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
+ -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> Maybe ThetaType
+ -> TcRn (Maybe EarlyDerivSpec)
+mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
+ cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
+ | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
+ = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
+ ; dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; let spec = DS { ds_loc = loc, ds_orig = orig
+ , ds_name = dfun_name, ds_tvs = dict_tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_theta = mtheta `orElse` all_preds
+ , ds_newtype = True }
+ ; return (if isJust mtheta then Just (Right spec)
+ else Just (Left spec)) }
+
+ | isNothing mb_std_err -- Use the standard H98 method
+ = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+
+ -- Otherwise we can't derive
+ | 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 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")]
+