= 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
+ is_boot <- tcIsHsBoot
+ ; traceTc (text "tcDeriving" <+> ppr is_boot)
+ ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
; insts2 <- mapM (genInst overlap_flag) final_specs
- ; is_boot <- tcIsHsBoot
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds is_boot
; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
all those.
\begin{code}
-makeDerivSpecs :: [LTyClDecl Name]
+makeDerivSpecs :: Bool
+ -> [LTyClDecl Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM [EarlyDerivSpec]
-makeDerivSpecs tycl_decls inst_decls deriv_decls
- = do { eqns1 <- mapAndRecoverM deriveTyData $
- extractTyDataPreds tycl_decls ++
- [ pd -- traverse assoc data families
- | L _ (InstDecl _ _ _ ats) <- inst_decls
- , pd <- extractTyDataPreds ats ]
+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 (catMaybes (eqns1 ++ eqns2)) }
where
- extractTyDataPreds decls =
- [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
+ 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 tycl_decls ++
+ [ pd -- Traverse assoc data families
+ | L _ (InstDecl _ _ _ ats) <- inst_decls
+ , pd <- extractTyDataPreds ats ]
+
+ 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 (Maybe EarlyDerivSpec)
-- 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
+ -- 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.
-- By this time we know that the thing is algebraic
-- because we've called checkInstHead in derivingStandalone
; 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)
+ ; checkTc (isNothing mtheta ||
+ not hidden_data_cons ||
+ className cls `elem` typeableClassNames)
(derivingHiddenErr tycon)
; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys
= failWithTc (ptext (sLit "No family instance for")
- <+> quotes (pprTypeApp tycon (ppr tycon) tys))
+ <+> quotes (pprTypeApp tycon tys))
\end{code}