X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=38567e6aae68f237860090969fd7676328c9dfed;hb=49ac6c398f2915de9eadff3cd2631bc31f806ec8;hp=1d23c7bd95b3d59240c0b42e3cc34cc79796132d;hpb=d876992cf9b9fb07cb913b0c297d9a42b746c29a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 1d23c7b..38567e6 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -10,10 +10,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" -import HsSyn ( HsBinds(..), TyClDecl(..), MonoBinds(..), - andMonoBindList ) -import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred ) +import HsSyn import CmdLineOpts ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) @@ -27,10 +24,10 @@ import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) 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 ) @@ -39,24 +36,27 @@ import ErrUtils ( dumpIfSet_dyn ) 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 Kind ( splitKindFunTys ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, tyConTheta, isProductTyCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, getClassPredTys_maybe, tcTyConAppTyCon, - isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind, + 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 ListSetOps ( removeDups, assoc ) import Outputable +import Bag \end{code} %************************************************************************ @@ -193,13 +193,13 @@ version. So now all classes are "offending". %************************************************************************ \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, emptyNameSet)) $ + = 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 @@ -219,9 +219,9 @@ tcDeriving tycl_decls -- which is used in the generic binds ; (rn_binds, gen_bndrs) <- discardWarnings $ setOptM Opt_GlasgowExts $ do - { (rn_deriv, _dus1) <- rnTopMonoBinds deriv_binds [] - ; (rn_gen, dus_gen) <- rnTopMonoBinds gen_binds [] - ; return (rn_deriv `ThenBinds` rn_gen, duDefs dus_gen) } + { (rn_deriv, _dus1) <- rnTopBinds deriv_binds [] + ; (rn_gen, dus_gen) <- rnTopBinds gen_binds [] + ; return (rn_deriv ++ rn_gen, duDefs dus_gen) } ; dflags <- getDOpts @@ -231,13 +231,13 @@ tcDeriving tycl_decls ; 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 pprInstInfoDetails inst_infos) $$ ppr extra_binds + = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds) ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], EmptyMonoBinds) + = returnM ([], emptyBag) deriveOrdinaryStuff eqns = do { -- Take the equation list and solve it, to deliver a list of @@ -254,13 +254,17 @@ deriveOrdinaryStuff eqns ; extra_binds <- genTaggeryBinds new_dfuns -- Done - ; returnM (inst_infos, andMonoBindList (extra_binds : aux_binds_s)) } + ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s)) + } ----------------------------------------- mkGenericBinds tycl_decls - = do { tcs <- mapM tcLookupTyCon [tc_name | TyData { tcdName = tc_name } <- 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 (andMonoBindList [mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc]) } + ; return (unionManyBags [ mkTyConGenericBinds tc | + tc <- tcs, tyConHasGenerics tc ]) } -- And then only in the ones whose 'has-generics' flag is on \end{code} @@ -287,7 +291,7 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: [RenamedTyClDecl] +makeDerivEqns :: [LTyClDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings @@ -296,21 +300,22 @@ makeDerivEqns tycl_decls 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 @@ -353,13 +358,13 @@ makeDerivEqns tycl_decls ] mk_eqn_help gla_exts NewType tycon clas tys - | can_derive_via_isomorphism && (gla_exts || standard_class gla_exts clas) + | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas) = -- 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, iBinds = NewTypeDerived rep_tys })) - | standard_class gla_exts clas + | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon clas tys -- Go via bale-out route | otherwise -- Non-standard instance @@ -386,7 +391,7 @@ makeDerivEqns tycl_decls -- Kind of the thing we want to instance -- e.g. argument kind of Monad, *->* - (arg_kinds, _) = tcSplitFunTys kind + (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s) @@ -504,12 +509,18 @@ makeDerivEqns tycl_decls ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")]) bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing) - standard_class gla_exts clas = key `elem` derivableClassKeys - || (gla_exts && (key == typeableClassKey || key == dataClassKey)) - where - key = classKey clas - +std_class gla_exts clas + = key `elem` derivableClassKeys + || (gla_exts && (key == typeableClassKey || key == dataClassKey)) + where + key = classKey clas + +std_class_via_iso clas -- These standard classes can be derived for a newtype + -- using the isomorphism trick *even if no -fglasgow-exts* + = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] + -- Not Read/Show because they respect the type + -- Not Enum, becuase newtypes are never in Enum new_dfun_name clas tycon -- Just a simple wrapper @@ -589,7 +600,7 @@ cond_isProduct (gla_exts, tycon) cond_allTypeKind :: Condition cond_allTypeKind (gla_exts, tycon) - | all (isTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing + | all (isArgTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing | otherwise = Just why where why = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'") @@ -665,7 +676,7 @@ solveDerivEqns orig_eqns ------------------------------------------------------------------ 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 @@ -739,17 +750,17 @@ Much less often (really just for deriving @Ix@), we use a \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, RdrNameMonoBinds) +genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName) genInst dfun = getFixityEnv `thenM` \ fix_env -> let @@ -768,7 +779,7 @@ genInst dfun returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_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)) @@ -782,7 +793,7 @@ gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_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} @@ -820,11 +831,11 @@ 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 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