import HscTypes ( DFunId, FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Subst ( mkTyVarSubst, substTheta )
+import Type ( zipTvSubst, substTheta )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullaryDataCon, isExistentialDataCon, dataConOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
-import NameSet ( NameSet, emptyNameSet, duDefs )
+import NameSet ( duDefs )
import Kind ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
- tyConTheta, isProductTyCon, isDataTyCon, newTyConRhs,
+ tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
import VarSet ( mkVarSet, subVarSet )
import PrelNames
import SrcLoc ( srcLocSpan, Located(..) )
-import Util ( zipWithEqual, sortLt, notNull )
+import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
import Bag
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls"
- [HsBindGroup Name], -- Extra generated top-level bindings
- NameSet) -- Binders to keep alive
+ [HsBindGroup Name]) -- Extra generated top-level bindings
tcDeriving tycl_decls
- = recoverM (returnM ([], [], emptyNameSet)) $
+ = recoverM (returnM ([], [])) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns 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
- ; (rn_binds, gen_bndrs)
+ ; rn_binds
<- 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) }
+ ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
+ -- be kept alive
+ ; return (rn_deriv ++ rn_gen) }
; 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)
+ ; returnM (inst_info, rn_binds)
}
where
ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
-----------------------------------------
deriveOrdinaryStuff [] -- Short cut
- = returnM ([], emptyBag)
+ = returnM ([], emptyLHsBinds)
deriveOrdinaryStuff eqns
= do { -- Take the equation list and solve it, to deliver a list of
mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
- addSrcSpan (srcLocSpan (getSrcLoc tycon)) $
+ setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
-- There's no 'corece' needed because after the type checker newtypes
-- are transparent.
- sc_theta = substTheta (mkTyVarSubst clas_tyvars inst_tys)
+ sc_theta = substTheta (zipTvSubst clas_tyvars inst_tys)
(classSCTheta clas)
-- If there are no tyvars, there's no need
where
tyvars = tyConTyVars tycon
constraints = extra_constraints ++ ordinary_constraints
- extra_constraints = tyConTheta tycon
+ extra_constraints = tyConStupidTheta tycon
-- "extra_constraints": see note [Data decl contexts] above
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
arg_ty <- dataConOrigArgTys data_con,
- -- Use the same type variables
- -- as the type constructor,
- -- hence no need to instantiate
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
cond_std :: Condition
cond_std (gla_exts, tycon)
- | any isExistentialDataCon data_cons = Just existential_why
- | null data_cons = Just no_cons_why
- | otherwise = Nothing
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
where
data_cons = tyConDataCons tycon
no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = addSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
addErrCtxt (derivCtxt (Just clas) tc) $
tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
- returnM (sortLt (<) theta) -- Canonicalise before returning the soluction
+ returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
= mkDictFunId dfun_name tyvars theta
genDerivBinds clas fix_env tycon
| className clas `elem` typeableClassNames
- = (gen_Typeable_binds tycon, emptyBag)
+ = (gen_Typeable_binds tycon, emptyLHsBinds)
| otherwise
= case assocMaybe gen_list (getUnique clas) of
-- 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, emptyBag)
+ no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
ignore_fix_env f fix_env tc = f tc
\end{code}
do_con2tag acc_Names tycon
| isDataTyCon tycon &&
((we_are_deriving eqClassKey tycon
- && any isNullaryDataCon (tyConDataCons tycon))
+ && any isNullarySrcDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (isProductTyCon tycon))
|| (we_are_deriving enumClassKey tycon)