X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=033e3990590e57d8ea0710d6096dbed0610cd2d8;hp=bacc25c9c5e8a65a2691e17a439ad4017441adcd;hb=8611d7d952b4a5bb0046898b386ded8fb287fdfa;hpb=2ce87c70529c2a75071161bd3d22b029f003ba36 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index bacc25c..033e399 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -18,13 +18,14 @@ import TcRnMonad import TcMType ( checkValidInstance ) import TcEnv ( newDFunName, pprInstInfoDetails, InstInfo(..), InstBindings(..), simpleInstInfoClsTy, - tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv + tcLookupClass, tcLookupTyCon, tcLookupLocatedTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList ) import Inst ( getOverlapFlag ) import TcHsType ( tcHsDeriv ) import TcSimplify ( tcSimplifyDeriv ) +import TypeRep ( PredType ) import RnBinds ( rnMethodBinds, rnTopBinds ) import RnEnv ( bindLocalNames ) @@ -41,7 +42,7 @@ import Name ( Name, getSrcLoc ) import NameSet ( duDefs ) import Type ( splitKindFunTys ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, - tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs, + tyConStupidTheta, isProductTyCon, isDataTyCon, isNewTyCon, newTyConRhs, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, @@ -50,7 +51,7 @@ import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, import Var ( TyVar, tyVarKind, varName ) import VarSet ( mkVarSet, disjointVarSet ) import PrelNames -import SrcLoc ( srcLocSpan, Located(..) ) +import SrcLoc ( SrcSpan, srcLocSpan, Located(..), unLoc ) import Util ( zipWithEqual, sortLe, notNull ) import ListSetOps ( removeDups, assocMaybe ) import Outputable @@ -142,12 +143,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 +208,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 +341,59 @@ 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 | 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 +401,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 +577,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 +591,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,11 +763,12 @@ 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 + tcSimplifyDeriv orig tc tyvars deriv_rhs ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $ checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction @@ -764,7 +776,8 @@ solveDerivEqns overlap_flag orig_eqns ------------------------------------------------------------------ - 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