X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=7ed64c16288850570623b405ac2cc9687a54598c;hb=c51fdf4422e1c45aa99e0151c2ac1132cecea128;hp=f1e72beff75d83e6311c14edb55398bb55686d67;hpb=40888e1d6141c919254f93545ae0d795e20ae4bf;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index f1e72be..7ed64c1 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -20,39 +20,36 @@ import TcEnv ( newDFunName, pprInstInfoDetails, 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 @@ -208,11 +205,10 @@ And then translate it to: \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 @@ -223,26 +219,37 @@ tcDeriving 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 @@ -250,7 +257,7 @@ tcDeriving tycl_decls ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], emptyBag) + = returnM ([], emptyLHsBinds) deriveOrdinaryStuff eqns = do { -- Take the equation list and solve it, to deliver a list of @@ -330,7 +337,7 @@ makeDerivEqns tycl_decls 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 @@ -434,7 +441,7 @@ makeDerivEqns tycl_decls -- 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 @@ -532,9 +539,10 @@ mkDataTypeEqn tycon clas -- 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 @@ -546,16 +554,13 @@ mkDataTypeEqn tycon clas 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? ] @@ -587,7 +592,7 @@ sideConditions (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) ] @@ -608,9 +613,9 @@ andCond c1 c2 tc = case c1 tc of 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") @@ -630,12 +635,17 @@ cond_isProduct (gla_exts, tycon) 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 @@ -708,10 +718,10 @@ solveDerivEqns orig_eqns ------------------------------------------------------------------ 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 @@ -722,7 +732,7 @@ extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a -- 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} @@ -812,7 +822,7 @@ genInst dfun 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 @@ -833,7 +843,7 @@ genDerivBinds clas fix_env tycon -- 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} @@ -884,7 +894,7 @@ genTaggeryBinds dfuns 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)