#include "HsVersions.h"
-import HsSyn ( HsBinds(..), TyClDecl(..), MonoBinds(..),
- andMonoBindList )
-import RdrHsSyn ( RdrNameMonoBinds )
-import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred )
+import HsSyn
import CmdLineOpts ( DynFlag(..) )
-import Generics ( mkGenericBinds )
+import Generics ( mkTyConGenericBinds )
import TcRnMonad
import TcEnv ( newDFunName,
- InstInfo(..), pprInstInfo, InstBindings(..),
+ InstInfo(..), InstBindings(..),
pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import TcHsType ( tcHsPred )
import TcSimplify ( tcSimplifyDeriv )
-import RnBinds ( rnMethodBinds, rnTopMonoBinds )
+import RnBinds ( rnMethodBinds, rnTopBinds )
import RnEnv ( bindLocalNames )
import TcRnMonad ( thenM, returnM, mapAndUnzipM )
-import HscTypes ( DFunId, FixityEnv, typeEnvTyCons )
+import HscTypes ( DFunId, FixityEnv )
import BasicTypes ( NewOrData(..) )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
import MkId ( mkDictFunId )
import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon )
import Maybes ( catMaybes )
+import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
+import NameSet ( NameSet, emptyNameSet, duDefs )
import Unique ( Unique, getUnique )
-import TyCon ( tyConTyVars, tyConDataCons, tyConArity,
+import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConTheta, isProductTyCon, isDataTyCon,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import Var ( TyVar, tyVarKind, idType, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
+import SrcLoc ( srcLocSpan, Located(..) )
import Util ( zipWithEqual, sortLt, notNull )
import ListSetOps ( removeDups, assoc )
import Outputable
+import Bag
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcDeriving :: [RenamedTyClDecl] -- All type constructors
+tcDeriving :: [LTyClDecl Name] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls"
- RenamedHsBinds) -- Extra generated top-level bindings
+ [HsBindGroup Name], -- Extra generated top-level bindings
+ NameSet) -- Binders to keep alive
tcDeriving tycl_decls
- = recoverM (returnM ([], EmptyBinds)) $
- getDOpts `thenM` \ dflags ->
+ = recoverM (returnM ([], [], emptyNameSet)) $
+ do { -- Fish the "deriving"-related information out of the TcEnv
+ -- and make the necessary "equations".
+ ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls
- -- Fish the "deriving"-related information out of the TcEnv
- -- and make the necessary "equations".
- makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) ->
- extendLocalInstEnv (map iDFunId newtype_inst_info) $
- -- Add the newtype-derived instances to the inst env
- -- before tacking the "ordinary" ones
+ ; (ordinary_inst_info, deriv_binds)
+ <- extendLocalInstEnv (map iDFunId newtype_inst_info) $
+ deriveOrdinaryStuff ordinary_eqns
+ -- Add the newtype-derived instances to the inst env
+ -- before tacking the "ordinary" ones
- deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds) ->
- let
- inst_info = newtype_inst_info ++ ordinary_inst_info
- in
+ -- Generate the generic to/from functions from each type declaration
+ ; gen_binds <- mkGenericBinds tycl_decls
+ ; let inst_info = newtype_inst_info ++ ordinary_inst_info
- ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
- (ddump_deriving inst_info binds)) `thenM_`
+ -- 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
+ ; (rn_binds, gen_bndrs)
+ <- discardWarnings $ setOptM Opt_GlasgowExts $ do
+ { (rn_deriv, _dus1) <- rnTopBinds deriv_binds []
+ ; (rn_gen, dus_gen) <- rnTopBinds gen_binds []
+ ; return (rn_deriv ++ rn_gen, duDefs dus_gen) }
- returnM (inst_info, binds)
+ ; dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+ (ddump_deriving inst_info rn_binds))
+
+ ; returnM (inst_info, rn_binds, gen_bndrs)
+ }
where
- ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
+ ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
ddump_deriving inst_infos extra_binds
- = vcat (map ppr_info inst_infos) $$ ppr extra_binds
-
- ppr_info inst_info = pprInstInfo inst_info $$
- nest 4 (pprInstInfoDetails inst_info)
- -- pprInstInfo doesn't print much: only the type
+ = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds)
-----------------------------------------
deriveOrdinaryStuff [] -- Short cut
- = returnM ([], EmptyBinds)
+ = returnM ([], emptyBag)
deriveOrdinaryStuff eqns
= do { -- Take the equation list and solve it, to deliver a list of
-- notably "con2tag" and/or "tag2con" functions.
; extra_binds <- genTaggeryBinds new_dfuns
- -- Generate the generic to/from functions from each type declaration
- ; tcg_env <- getGblEnv
- ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env))
-
- -- Rename these extra bindings
- ; (rn_binds, _fvs1) <- rnTopMonoBinds (extra_binds `AndMonoBinds` gen_binds) []
-
- ; let all_binds = rn_binds `ThenBinds`
- foldr ThenBinds EmptyBinds aux_binds_s
-
-- Done
- ; traceTc (text "tcDeriv" <+> vcat (map pprInstInfo inst_infos))
- ; returnM (inst_infos, all_binds) }
+ ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s))
+ }
+
+-----------------------------------------
+mkGenericBinds tycl_decls
+ = do { tcs <- mapM tcLookupTyCon
+ [ tc_name |
+ L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
+ -- We are only interested in the data type declarations
+ ; return (unionManyBags [ mkTyConGenericBinds tc |
+ tc <- tcs, tyConHasGenerics tc ]) }
+ -- And then only in the ones whose 'has-generics' flag is on
\end{code}
all those.
\begin{code}
-makeDerivEqns :: [RenamedTyClDecl]
+makeDerivEqns :: [LTyClDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
- derive_these :: [(NewOrData, Name, RenamedHsPred)]
+ derive_these :: [(NewOrData, Name, LHsPred Name)]
-- Find the (nd, TyCon, Pred) pairs that must be `derived'
-- NB: only source-language decls have deriving, no imported ones do
derive_these = [ (nd, tycon, pred)
- | TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls,
+ | L _ (TyData { tcdND = nd, tcdLName = L _ tycon,
+ tcdDerivs = Just (L _ preds) }) <- tycl_decls,
pred <- preds ]
------------------------------------------------------------------
- mk_eqn :: (NewOrData, Name, RenamedHsPred) -> TcM (Maybe DerivEqn, Maybe InstInfo)
+ mk_eqn :: (NewOrData, Name, LHsPred Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
mk_eqn (new_or_data, tycon_name, pred)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
- addSrcLoc (getSrcLoc tycon) $
+ addSrcSpan (srcLocSpan (getSrcLoc tycon)) $
addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = addSrcLoc (getSrcLoc tc) $
+ = addSrcSpan (srcLocSpan (getSrcLoc tc)) $
addErrCtxt (derivCtxt (Just clas) tc) $
tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
returnM (sortLt (<) theta) -- Canonicalise before returning the soluction
\item
We use the renamer!!! Reason: we're supposed to be
-producing @RenamedMonoBinds@ for the methods, but that means
+producing @LHsBinds Name@ for the methods, but that means
producing correctly-uniquified code on the fly. This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
-So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
+So, instead, we produce @MonoBinds RdrName@ then heave 'em through
the renamer. What a great hack!
\end{itemize}
\begin{code}
-- Generate the InstInfo for the required instance,
-- plus any auxiliary bindings required
-genInst :: DFunId -> TcM (InstInfo, RenamedHsBinds)
+genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName)
genInst dfun
= getFixityEnv `thenM` \ fix_env ->
let
(meth_binds, aux_binds) = assoc "gen_bind:bad derived class"
gen_list (getUnique clas) fix_env tycon
in
- -- Rename the auxiliary bindings (if any)
- rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, _dus) ->
-
-- Bring the right type variables into
-- scope, and rename the method binds
bindLocalNames (map varName tyvars) $
-- Build the InstInfo
returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] },
- rn_aux_binds)
+ aux_binds)
-gen_list :: [(Unique, FixityEnv -> TyCon -> (RdrNameMonoBinds, RdrNameMonoBinds))]
+gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds))
,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds))
,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds))
-- no_aux_binds is used for generators that don't
-- need to produce any auxiliary bindings
-no_aux_binds f fix_env tc = (f fix_env tc, EmptyMonoBinds)
+no_aux_binds f fix_env tc = (f fix_env tc, emptyBag)
ignore_fix_env f fix_env tc = f tc
\end{code}
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-genTaggeryBinds :: [DFunId] -> TcM RdrNameMonoBinds
+genTaggeryBinds :: [DFunId] -> TcM (LHsBinds RdrName)
genTaggeryBinds dfuns
= do { names_so_far <- foldlM do_con2tag [] tycons_of_interest
; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest
- ; return (andMonoBindList (map gen_tag_n_con_monobind nm_alist_etc)) }
+ ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) }
where
all_CTs = map simpleDFunClassTyCon dfuns
all_tycons = map snd all_CTs