tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
-import InstEnv ( simpleDFunClassTyCon, extendInstEnv )
+import InstEnv ( simpleDFunClassTyCon, extendInstEnvList )
import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopBinds )
import RnEnv ( bindLocalNames )
-import TcRnMonad ( thenM, returnM, mapAndUnzipM )
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 Unique ( Unique, getUnique )
+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,
- tcSplitForAllTys, tcSplitPredTy_maybe, getClassPredTys_maybe, tcTyConAppTyCon,
+import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
import Var ( TyVar, tyVarKind, idType, varName )
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
-- Add the newtype-derived instances to the inst env
-- before tacking the "ordinary" ones
+ ; let inst_info = newtype_inst_info ++ ordinary_inst_info
+
+ -- If we are compiling a hs-boot file,
+ -- don't generate any derived bindings
+ ; is_boot <- tcIsHsBoot
+ ; if is_boot then
+ return (inst_info, [])
+ else do
+ {
+
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds tycl_decls
- ; let inst_info = newtype_inst_info ++ ordinary_inst_info
-- 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
ddump_deriving inst_infos extra_binds
-----------------------------------------
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
-- 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
- -- 2. The actual class we want to generate isn't necessarily
+ -- 3. The actual class we want to generate isn't necessarily
-- Typeable; it depends on the arity of the type
do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
; dfun_name <- new_dfun_name real_clas tycon
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?
]
(enumClassKey, cond_std `andCond` cond_isEnumeration),
(ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
(boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
- (typeableClassKey, cond_glaExts `andCond` cond_allTypeKind),
+ (typeableClassKey, cond_glaExts `andCond` cond_typeableOK),
(dataClassKey, cond_glaExts `andCond` cond_std)
]
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")
where
why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
-cond_allTypeKind :: Condition
-cond_allTypeKind (gla_exts, tycon)
- | all (isArgTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing
- | otherwise = Just why
+cond_typeableOK :: Condition
+-- OK for Typeable class
+-- Currently: (a) args all of kind *
+-- (b) 7 or fewer args
+cond_typeableOK (gla_exts, tycon)
+ | tyConArity tycon > 7 = Just too_many
+ | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+ | otherwise = Nothing
where
- why = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'")
+ too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
+ bad_kind = quotes (ppr tycon) <+> ptext SLIT("has arguments of kind other than `*'")
cond_glaExts :: Condition
cond_glaExts (gla_exts, tycon) | gla_exts = Nothing
------------------------------------------------------------------
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
-- for functional dependency errors -- that'll happen in TcInstDcls
extendLocalInstEnv dfuns thing_inside
= do { env <- getGblEnv
- ; let inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns
+ ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
env' = env { tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
\end{code}
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)
projects / ghc-hetmet.git / blobdiff