+
+%************************************************************************
+%* *
+ From HsSyn to DerivSpec
+%* *
+%************************************************************************
+
+@makeDerivSpecs@ fishes around to find the info about needed derived instances.
+
+\begin{code}
+makeDerivSpecs :: Bool
+ -> [LTyClDecl Name]
+ -> [LInstDecl Name]
+ -> [LDerivDecl Name]
+ -> TcM [EarlyDerivSpec]
+
+makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ | is_boot -- No 'deriving' at all in hs-boot files
+ = do { mapM_ add_deriv_err deriv_locs
+ ; return [] }
+ | otherwise
+ = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
+ ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
+ ; return (eqns1 ++ eqns2) }
+ where
+ extractTyDataPreds decls
+ = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+
+ all_tydata :: [(LHsType Name, LTyClDecl Name)]
+ -- Derived predicate paired with its data type declaration
+ all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
+
+ deriv_locs = map (getLoc . snd) all_tydata
+ ++ map getLoc deriv_decls
+
+ add_deriv_err loc = setSrcSpan loc $
+ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+ 2 (ptext (sLit "Use an instance declaration instead")))
+
+------------------------------------------------------------------
+deriveStandalone :: LDerivDecl Name -> TcM 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 "Standalone deriving decl for" (ppr deriv_ty)
+ ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
+ ; traceTc "Standalone deriving;" $ vcat
+ [ text "tvs:" <+> ppr tvs
+ , text "theta:" <+> ppr theta
+ , text "tau:" <+> ppr tau ]
+ ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau
+ -- C.f. TcInstDcls.tcLocalInstDecl1
+
+ ; let cls_tys = take (length inst_tys - 1) inst_tys
+ inst_ty = last inst_tys
+ ; traceTc "Standalone deriving:" $ vcat
+ [ 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 EarlyDerivSpec
+deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
+ tcdTyVars = tv_names,
+ tcdTyPats = ty_pats }))
+ = setSrcSpan loc $ -- Use the location of the 'deriving' item
+ tcAddDeclCtxt decl $
+ do { (tvs, tc, tc_args) <- get_lhs ty_pats
+ ; 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]).
+
+ -- Given data T a b c = ... deriving( C d ),
+ -- we want to drop type variables from T so that (C d (T a)) is well-kinded
+ ; let cls_tyvars = classTyVars cls
+ kind = tyVarKind (last cls_tyvars)
+ (arg_kinds, _) = splitKindFunTys kind
+ n_args_to_drop = length arg_kinds
+ n_args_to_keep = tyConArity tc - n_args_to_drop
+ args_to_drop = drop n_args_to_keep tc_args
+ inst_ty = mkTyConApp tc (take n_args_to_keep tc_args)
+ inst_ty_kind = typeKind inst_ty
+ dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
+ univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
+ `minusVarSet` dropped_tvs
+
+ -- Check that the result really is well-kinded
+ ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
+ (derivingKindErr tc cls cls_tys kind)
+
+ ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a)
+ tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
+ (derivingEtaErr cls cls_tys inst_ty)
+ -- Check that
+ -- (a) The data type can be eta-reduced; eg reject:
+ -- data instance T a a = ... deriving( Monad )
+ -- (b) The type class args do not mention any of the dropped type
+ -- variables
+ -- newtype T a s = ... deriving( ST s )
+
+ -- Type families can't be partially applied
+ -- e.g. newtype instance T Int a = MkT [a] deriving( Monad )
+ -- Note [Deriving, type families, and partial applications]
+ ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
+ (typeFamilyPapErr tc cls cls_tys inst_ty)
+
+ ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
+ where
+ -- Tiresomely we must figure out the "lhs", which is awkward for type families
+ -- E.g. data T a b = .. deriving( Eq )
+ -- Here, the lhs is (T a b)
+ -- data instance TF Int b = ... deriving( Eq )
+ -- Here, the lhs is (TF Int b)
+ -- But if we just look up the tycon_name, we get is the *family*
+ -- tycon, but not pattern types -- they are in the *rep* tycon.
+ get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
+ ; let tvs = tyConTyVars tc
+ ; return (tvs, tc, mkTyVarTys tvs) }
+ get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
+ ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
+ ; let (tc, tc_args) = tcSplitTyConApp tc_app
+ ; return (tvs, tc, tc_args) }
+
+deriveTyData _other
+ = panic "derivTyData" -- Caller ensures that only TyData can happen
+\end{code}
+
+Note [Deriving, type families, and partial applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 (: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:
+
+ data family T a b
+ newtype instance T Int a = MkT [a] deriving( Eq, Monad )
+ -- :RT is the representation type for (T Int a)
+ -- :CoF:R1T a :: T Int a ~ :RT a -- Not eta reduced
+ -- :Co:R1T :: :RT ~ [] -- Eta-reduced
+
+ instance Eq [a] => Eq (T Int a) -- easy by coercion
+ instance Monad [] => Monad (T Int) -- only if we can eta reduce???
+
+The "???" bit is that we don't build the :CoF thing in eta-reduced form
+Henc the current typeFamilyPapErr, even though the instance makes sense.
+After all, we can write it out
+ instance Monad [] => Monad (T Int) -- only if we can eta reduce???
+ return x = MkT [x]
+ ... etc ...
+
+\begin{code}
+mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
+ -> DerivContext -- Just => context supplied (standalone deriving)
+ -- Nothing => context inferred (deriving on data decl)
+ -> TcRn EarlyDerivSpec
+-- Make the EarlyDerivSpec for an instance
+-- forall tvs. theta => cls (tys ++ [ty])
+-- where the 'theta' is optional (that's the Maybe part)
+-- Assumes that this declaration is well-kinded
+
+mkEqnHelp orig tvs cls cls_tys tc_app mtheta
+ | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
+ , isAlgTyCon tycon -- Check for functions, primitive types etc
+ = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst 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.
+ -- No need for this when deriving Typeable, becuase we don't need
+ -- the constructors for that.
+ ; 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 ||
+ className cls `elem` typeableClassNames)
+ (derivingHiddenErr tycon)
+
+ ; dflags <- getDOpts
+ ; if isDataTyCon rep_tc then
+ mkDataTypeEqn orig dflags tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args mtheta
+ else
+ mkNewTypeEqn orig dflags tvs cls cls_tys
+ tycon tc_args rep_tc rep_tc_args mtheta }
+ | otherwise
+ = failWithTc (derivingThingErr False cls cls_tys tc_app
+ (ptext (sLit "The last argument of the instance must be a data or newtype application")))