X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=472ce6b94d3942ba706c186acbff3ea569ba2a05;hb=8e512635b618e1daa97022265f268ad4eafda6b4;hp=b8a5f1df34428bf4084a3e6a1c8d4c0e94e74143;hpb=c2527e8dea810f1584609ad20408a38691131d28;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index b8a5f1d..472ce6b 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,45 +11,46 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) import TcRnMonad import TcEnv ( newDFunName, pprInstInfoDetails, - InstInfo(..), InstBindings(..), + InstInfo(..), InstBindings(..), simpleInstInfoClsTy, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) +import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList ) +import Inst ( getOverlapFlag ) import TcHsType ( tcHsDeriv ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopBinds ) import RnEnv ( bindLocalNames ) -import HscTypes ( DFunId, FixityEnv ) +import HscTypes ( FixityEnv ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) -import Subst ( mkTyVarSubst, substTheta ) +import Type ( zipOpenTvSubst, 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, isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind, - tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) -import Var ( TyVar, tyVarKind, idType, varName ) + tcEqTypes, tcSplitAppTys, mkAppTys ) +import Var ( TyVar, tyVarKind, 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 @@ -205,63 +206,74 @@ 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 + HsValBinds Name) -- Extra generated top-level bindings tcDeriving tycl_decls - = recoverM (returnM ([], [], emptyNameSet)) $ + = recoverM (returnM ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls + overlap_flag <- getOverlapFlag + ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls ; (ordinary_inst_info, deriv_binds) - <- extendLocalInstEnv (map iDFunId newtype_inst_info) $ - deriveOrdinaryStuff ordinary_eqns + <- extendLocalInstEnv (map iSpec newtype_inst_info) $ + deriveOrdinaryStuff overlap_flag ordinary_eqns -- 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, emptyValBindsOut) + 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) } + { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds []) + ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds []) + ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to + -- be kept alive + ; return (rn_deriv `plusHsValBinds` 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 :: [InstInfo] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds - = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds) + = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds ----------------------------------------- -deriveOrdinaryStuff [] -- Short cut - = returnM ([], emptyBag) +deriveOrdinaryStuff overlap_flag [] -- Short cut + = returnM ([], emptyLHsBinds) -deriveOrdinaryStuff eqns +deriveOrdinaryStuff overlap_flag eqns = do { -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. - ; new_dfuns <- solveDerivEqns eqns + inst_specs <- solveDerivEqns overlap_flag eqns -- Generate the InstInfo for each dfun, -- plus any auxiliary bindings it needs - ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst new_dfuns + ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs -- Generate any extra not-one-inst-decl-specific binds, -- notably "con2tag" and/or "tag2con" functions. - ; extra_binds <- genTaggeryBinds new_dfuns + ; extra_binds <- genTaggeryBinds inst_infos -- Done ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s)) @@ -301,11 +313,12 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: [LTyClDecl Name] +makeDerivEqns :: OverlapFlag + -> [LTyClDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings -makeDerivEqns tycl_decls +makeDerivEqns overlap_flag tycl_decls = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) -> returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where @@ -327,7 +340,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 @@ -348,7 +361,7 @@ makeDerivEqns tycl_decls = -- Go ahead and use the isomorphism traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` new_dfun_name clas tycon `thenM` \ dfun_name -> - returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name, + returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, iBinds = NewTypeDerived rep_tys })) | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route @@ -431,7 +444,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 (zipOpenTvSubst clas_tyvars inst_tys) (classSCTheta clas) -- If there are no tyvars, there's no need @@ -441,7 +454,10 @@ makeDerivEqns tycl_decls | otherwise = rep_pred : sc_theta -- Finally! Here's where we build the dictionary Id - mk_dfun dfun_name = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys + mk_inst_spec dfun_name + = mkLocalInstance dfun overlap_flag + where + dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing @@ -544,16 +560,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? ] @@ -606,13 +619,13 @@ 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") - existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)") + existential_why = quotes (ppr tycon) <+> ptext SLIT("has non-Haskell-98 constructor(s)") cond_isEnumeration :: Condition cond_isEnumeration (gla_exts, tycon) @@ -668,11 +681,12 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -solveDerivEqns :: [DerivEqn] - -> TcM [DFunId] -- Solns in same order as eqns. +solveDerivEqns :: OverlapFlag + -> [DerivEqn] + -> TcM [Instance]-- Solns in same order as eqns. -- This bunch is Absolutely minimal... -solveDerivEqns orig_eqns +solveDerivEqns overlap_flag orig_eqns = iterateDeriv 1 initial_solutions where -- The initial solutions for the equations claim that each @@ -686,7 +700,7 @@ solveDerivEqns orig_eqns -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. -- It fails if any iteration fails - iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId] + iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance] iterateDeriv n current_solns | n > 20 -- Looks as if we are in an infinite loop -- This can happen if we have -fallow-undecidable-instances @@ -695,37 +709,40 @@ solveDerivEqns orig_eqns (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns) | otherwise = let - dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns + inst_specs = zipWithEqual "add_solns" mk_inst_spec + orig_eqns current_solns in checkNoErrs ( -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - extendLocalInstEnv dfuns $ + extendLocalInstEnv inst_specs $ mappM gen_soln orig_eqns ) `thenM` \ new_solns -> if (current_solns == new_solns) then - returnM dfuns + returnM inst_specs else iterateDeriv (n+1) new_solns ------------------------------------------------------------------ - 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 + tcSimplifyDeriv tc tyvars deriv_rhs `thenM` \ theta -> + returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction -mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta - = mkDictFunId dfun_name tyvars theta - clas [mkTyConApp tycon (mkTyVarTys tyvars)] - -extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a --- Add new locall-defined instances; don't bother to check + ------------------------------------------------------------------ + mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta + = mkLocalInstance dfun overlap_flag + where + dfun = mkDictFunId dfun_name tyvars theta clas + [mkTyConApp tycon (mkTyVarTys tyvars)] + +extendLocalInstEnv :: [Instance] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check -- 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} @@ -795,27 +812,32 @@ the renamer. What a great hack! \begin{code} -- Generate the InstInfo for the required instance, -- plus any auxiliary bindings required -genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName) -genInst dfun - = getFixityEnv `thenM` \ fix_env -> - let - (tyvars,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - clas_nm = className clas - tycon = tcTyConAppTyCon ty - (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon - in +genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName) +genInst spec + = do { fix_env <- getFixityEnv + ; let + (tyvars,_,clas,[ty]) = instanceHead spec + clas_nm = className clas + tycon = tcTyConAppTyCon ty + (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon + -- Bring the right type variables into -- scope, and rename the method binds - bindLocalNames (map varName tyvars) $ - rnMethodBinds clas_nm [] meth_binds `thenM` \ (rn_meth_binds, _fvs) -> + -- It's a bit yukky that we return *renamed* InstInfo, but + -- *non-renamed* auxiliary bindings + ; (rn_meth_binds, _fvs) <- discardWarnings $ + bindLocalNames (map varName tyvars) $ + rnMethodBinds clas_nm [] meth_binds -- Build the InstInfo - returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, - aux_binds) + ; return (InstInfo { iSpec = spec, + iBinds = VanillaInst rn_meth_binds [] }, + aux_binds) + } 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 @@ -836,7 +858,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} @@ -874,20 +896,22 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -genTaggeryBinds :: [DFunId] -> TcM (LHsBinds RdrName) -genTaggeryBinds dfuns +genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName) +genTaggeryBinds infos = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) } where - all_CTs = map simpleDFunClassTyCon dfuns + all_CTs = [ (cls, tcTyConAppTyCon ty) + | info <- infos, + let (cls,ty) = simpleInstInfoClsTy info ] all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons 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)