X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=90ff3a7c8c1611ec906ca4f307294161fb75f1fe;hb=2423c249f5ca7785d0ec89eb33e72662da7561c1;hp=11ff67229845c05632984bb4ad8ac5e3aa519bee;hpb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 11ff672..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, tcLookupLocatedTyCon, 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, isNewTyCon, 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(..), unLoc ) -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 @@ -350,52 +341,52 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls 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 (NewOrData, Name, LHsType Name)) + 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 (new_or_data, unLoc ty_name, inst) + return $ Just (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst) ------------------------------------------------------------------ -- takes (whether newtype or data, name of data type, partially applied type class) - mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) + 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 @@ -403,7 +394,7 @@ makeDerivEqns overlap_flag tycl_decls deriv_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 @@ -579,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 ) @@ -593,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 @@ -765,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 @@ -872,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 @@ -1001,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}