X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=90ff3a7c8c1611ec906ca4f307294161fb75f1fe;hb=680f11d3f1ad9065c4969ed5d9db857cc245d778;hp=bacc25c9c5e8a65a2691e17a439ad4017441adcd;hpb=2ce87c70529c2a75071161bd3d22b029f003ba36;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index bacc25c..90ff3a7 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1,7 +1,7 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcDeriv]{Deriving} Handles @deriving@ clauses on @data@ declarations. @@ -11,48 +11,38 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn -import DynFlags ( DynFlag(..) ) +import DynFlags -import Generics ( mkTyConGenericBinds ) +import Generics import TcRnMonad -import TcMType ( checkValidInstance ) -import TcEnv ( newDFunName, pprInstInfoDetails, - InstInfo(..), InstBindings(..), simpleInstInfoClsTy, - tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv - ) +import TcEnv import TcGenDeriv -- Deriv stuff -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 ( FixityEnv ) - -import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) -import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy ) -import ErrUtils ( dumpIfSet_dyn ) -import MkId ( mkDictFunId ) -import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConInstOrigArgTys ) -import Maybes ( catMaybes ) -import RdrName ( RdrName ) -import Name ( Name, getSrcLoc ) -import NameSet ( duDefs ) -import Type ( splitKindFunTys ) -import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, - tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs, - isEnumerationTyCon, isRecursiveTyCon, TyCon - ) -import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, - isUnLiftedType, mkClassPred, tyVarsOfType, tyVarsOfTypes, - isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys ) -import Var ( TyVar, tyVarKind, varName ) -import VarSet ( mkVarSet, disjointVarSet ) +import InstEnv +import Inst +import TcHsType +import TcSimplify + +import RnBinds +import RnEnv +import HscTypes + +import Class +import Type +import ErrUtils +import MkId +import DataCon +import Maybes +import RdrName +import Name +import NameSet +import TyCon +import TcType +import Var +import VarSet import PrelNames -import SrcLoc ( srcLocSpan, Located(..) ) -import Util ( zipWithEqual, sortLe, notNull ) -import ListSetOps ( removeDups, assocMaybe ) +import SrcLoc +import Util +import ListSetOps import Outputable import Bag \end{code} @@ -142,12 +132,13 @@ this by simplifying the RHS to a form in which So, here are the synonyms for the ``equation'' structures: \begin{code} -type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs) +type DerivEqn = (SrcSpan, InstOrigin, Name, Class, TyCon, [TyVar], DerivRhs) -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the RHS -pprDerivEqn (n,c,tc,tvs,rhs) - = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs) +pprDerivEqn :: DerivEqn -> SDoc +pprDerivEqn (l,_,n,c,tc,tvs,rhs) + = parens (hsep [ppr l, ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs) type DerivRhs = ThetaType type DerivSoln = DerivRhs @@ -206,15 +197,17 @@ And then translate it to: \begin{code} tcDeriving :: [LTyClDecl Name] -- All type constructors + -> [LDerivDecl Name] -- All stand-alone deriving declarations -> TcM ([InstInfo], -- The generated "instance decls" HsValBinds Name) -- Extra generated top-level bindings -tcDeriving tycl_decls +tcDeriving tycl_decls deriv_decls = recoverM (returnM ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". overlap_flag <- getOverlapFlag - ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls + ; (ordinary_eqns, newtype_inst_info) + <- makeDerivEqns overlap_flag tycl_decls deriv_decls ; (ordinary_inst_info, deriv_binds) <- extendLocalInstEnv (map iSpec newtype_inst_info) $ @@ -337,52 +330,63 @@ when the dict is constructed in TcInstDcls.tcInstDecl2 \begin{code} makeDerivEqns :: OverlapFlag -> [LTyClDecl Name] + -> [LDerivDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings -makeDerivEqns overlap_flag tycl_decls - = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) -> - returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) +makeDerivEqns overlap_flag tycl_decls deriv_decls + = do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes + (maybe_ordinaries, maybe_newtypes) + <- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level) + return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(NewOrData, Name, LHsType Name)] + derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)] -- Find the (nd, TyCon, Pred) pairs that must be `derived' - derive_these = [ (nd, tycon, pred) + derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, nd, tycon, pred) | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, tcdDerivs = Just preds }) <- tycl_decls, pred <- preds ] + top_level_deriv :: LDerivDecl Name -> TcM (Maybe (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)) + top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $ + do tycon <- tcLookupLocatedTyCon ty_name + let new_or_data = if isNewTyCon tycon then NewType else DataType + traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst)) + return $ Just (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst) + ------------------------------------------------------------------ - mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) + -- takes (whether newtype or data, name of data type, partially applied type class) + mk_eqn :: (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) -- We swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation -- -- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign -- we allow deriving (forall a. C [a]). - mk_eqn (new_or_data, tycon_name, hs_deriv_ty) + mk_eqn (loc, orig, new_or_data, tycon_name, hs_deriv_ty) = tcLookupTyCon tycon_name `thenM` \ tycon -> - setSrcSpan (srcLocSpan (getSrcLoc tycon)) $ + setSrcSpan loc $ addErrCtxt (derivCtxt tycon) $ tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention -- the type variables for the type constructor tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) -> doptM Opt_GlasgowExts `thenM` \ gla_exts -> - mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys + mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys ------------------------------------------------------------------ -- data/newtype T a = ... deriving( C t1 t2 ) -- leads to a call to mk_eqn_help with -- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2] - mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys + mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err) | otherwise - = do { eqn <- mkDataTypeEqn tycon clas + = do { eqn <- mkDataTypeEqn loc orig tycon clas ; returnM (Just eqn, Nothing) } - mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys + mk_eqn_help loc orig gla_exts NewType tycon deriv_tvs clas tys | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas) = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) ; -- Go ahead and use the isomorphism @@ -390,7 +394,7 @@ makeDerivEqns overlap_flag tycl_decls ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, iBinds = NewTypeDerived ntd_info })) } | std_class gla_exts clas - = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route + = mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route | otherwise -- Non-standard instance = bale_out (if gla_exts then @@ -566,8 +570,8 @@ new_dfun_name clas tycon -- Just a simple wrapper -- a suitable string; hence the empty type arg list ------------------------------------------------------------------ -mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn -mkDataTypeEqn tycon clas +mkDataTypeEqn :: SrcSpan -> InstOrigin -> TyCon -> Class -> TcM DerivEqn +mkDataTypeEqn loc orig tycon clas | clas `hasKey` typeableClassKey = -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) @@ -580,11 +584,11 @@ mkDataTypeEqn tycon clas -- Typeable; it depends on the arity of the type do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; dfun_name <- new_dfun_name real_clas tycon - ; return (dfun_name, real_clas, tycon, [], []) } + ; return (loc, orig, dfun_name, real_clas, tycon, [], []) } | otherwise = do { dfun_name <- new_dfun_name clas tycon - ; return (dfun_name, clas, tycon, tyvars, constraints) } + ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) } where tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints @@ -752,19 +756,22 @@ solveDerivEqns overlap_flag orig_eqns iterateDeriv (n+1) new_solns ------------------------------------------------------------------ - gen_soln (_, clas, tc,tyvars,deriv_rhs) - = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ + gen_soln :: DerivEqn -> TcM [PredType] + gen_soln (loc, orig, _, clas, tc,tyvars,deriv_rhs) + = setSrcSpan loc $ do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)] ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $ - tcSimplifyDeriv tc tyvars deriv_rhs - ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $ - checkValidInstance tyvars theta clas inst_tys - ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction + tcSimplifyDeriv orig tc tyvars deriv_rhs + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution where ------------------------------------------------------------------ - mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta + mk_inst_spec :: DerivEqn -> DerivSoln -> Instance + mk_inst_spec (loc, orig, dfun_name, clas, tycon, tyvars, _) theta = mkLocalInstance dfun overlap_flag where dfun = mkDictFunId dfun_name tyvars theta clas @@ -859,7 +866,7 @@ genInst spec -- It's a bit yukky that we return *renamed* InstInfo, but -- *non-renamed* auxiliary bindings ; (rn_meth_binds, _fvs) <- discardWarnings $ - bindLocalNames (map varName tyvars) $ + bindLocalNames (map Var.varName tyvars) $ rnMethodBinds clas_nm (\n -> []) [] meth_binds -- Build the InstInfo @@ -988,10 +995,5 @@ derivCtxt tycon derivInstCtxt1 clas inst_tys = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys) - -derivInstCtxt2 theta clas inst_tys - = vcat [ptext SLIT("In the derived instance declaration"), - nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, - pprClassPred clas inst_tys])] \end{code}