From 9319fbaf14f420cbbd9e670093cc86c5f04b7800 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 1 Jul 2008 12:09:08 +0000 Subject: [PATCH 1/1] Several fixes to 'deriving' including Trac #2378 This patch collects several related things together. * Refactor TcDeriv so that the InstInfo and the method bindings are renamed together. This was messy before, and is cleaner now. Fixes a bug caused by interaction between the "auxiliary bindings" (which were given Original names before), and stand-alone deriving (which meant that those Original names came from a different module). Now the names are purely local an ordinary. To do this, InstInfo is parameterised like much else HsSyn stuff. * Improve the location info in a dfun, which in turn improves location info for error messages, e.g. overlapping instances * Make sure that newtype-deriving isn't used for Typeable1 and friends. (Typeable was rightly taken care of, but not Typeable1,2, etc.) * Check for data types in deriving Data, so that you can't do, say, deriving instance Data (IO a) * Decorate the derived binding with location info from the *instance* rather than from the *tycon*. Again, this really only matters with standalone deriving, but it makes a huge difference there. I think that's it. Quite a few error messages change slightly. If we release 6.8.4, this should go in if possible. --- compiler/typecheck/TcClassDcl.lhs | 10 +-- compiler/typecheck/TcDeriv.lhs | 152 +++++++++++++++++++++---------------- compiler/typecheck/TcEnv.lhs | 22 +++--- compiler/typecheck/TcGenDeriv.lhs | 146 +++++++++++++++++------------------ compiler/typecheck/TcHsType.lhs | 4 +- compiler/typecheck/TcInstDcls.lhs | 17 +++-- 6 files changed, 181 insertions(+), 170 deletions(-) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8b43ad6..1fd8706 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -594,7 +594,7 @@ gives rise to the instance declarations \begin{code} -getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo] +getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] getGenericInstances class_decls = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls ; let { gen_inst_info = concat gen_inst_infos } @@ -609,7 +609,7 @@ getGenericInstances class_decls (vcat (map pprInstInfoDetails gen_inst_info))) ; return gen_inst_info }} -get_generics :: TyClDecl Name -> TcM [InstInfo] +get_generics :: TyClDecl Name -> TcM [InstInfo Name] get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) | null generic_binds = return [] -- The comon case: no generic default methods @@ -634,7 +634,7 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) -- -- The class should be unary, which is why simpleInstInfoTyCon should be ok let - tc_inst_infos :: [(TyCon, InstInfo)] + tc_inst_infos :: [(TyCon, InstInfo Name)] tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, @@ -695,7 +695,7 @@ eqPatType _ _ = False --------------------------------- mkGenericInstance :: Class -> (HsType Name, LHsBinds Name) - -> TcM InstInfo + -> TcM (InstInfo Name) mkGenericInstance clas (hs_ty, binds) = do -- Make a generic instance declaration @@ -805,7 +805,7 @@ missingGenericInstances :: [Name] -> SDoc missingGenericInstances missing = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing -dupGenericInsts :: [(TyCon, InstInfo)] -> SDoc +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc dupGenericInsts tc_inst_infos = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"), nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 03638b1..7a2954a 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -262,7 +262,7 @@ when the dict is constructed in TcInstDcls.tcInstDecl2 tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM ([InstInfo], -- The generated "instance decls" + -> TcM ([InstInfo Name], -- The generated "instance decls" HsValBinds Name) -- Extra generated top-level bindings tcDeriving tycl_decls inst_decls deriv_decls @@ -273,18 +273,17 @@ tcDeriving tycl_decls inst_decls deriv_decls ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs - ; (insts1, aux_binds1) <- mapAndUnzipM (genInst overlap_flag) given_specs + ; insts1 <- mapM (genInst overlap_flag) given_specs - ; final_specs <- extendLocalInstEnv (map iSpec insts1) $ + ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ inferInstanceContexts overlap_flag infer_specs - ; (insts2, aux_binds2) <- mapAndUnzipM (genInst overlap_flag) final_specs + ; insts2 <- mapM (genInst overlap_flag) final_specs ; is_boot <- tcIsHsBoot - ; rn_binds <- makeAuxBinds is_boot tycl_decls - (concat aux_binds1 ++ concat aux_binds2) - - ; let inst_info = insts1 ++ insts2 + -- Generate the generic to/from functions from each type declaration + ; gen_binds <- mkGenericBinds is_boot + ; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) ; dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" @@ -292,49 +291,77 @@ tcDeriving tycl_decls inst_decls deriv_decls ; return (inst_info, rn_binds) } where - ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc + ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds -makeAuxBinds :: Bool -> [LTyClDecl Name] -> DerivAuxBinds -> TcM (HsValBinds Name) -makeAuxBinds is_boot tycl_decls deriv_aux_binds - | is_boot -- If we are compiling a hs-boot file, - -- don't generate any derived bindings - = return emptyValBindsOut +renameDeriv :: Bool -> LHsBinds RdrName + -> [(InstInfo RdrName, DerivAuxBinds)] + -> TcM ([InstInfo Name], HsValBinds Name) +renameDeriv is_boot gen_binds insts + | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings + -- The inst-info bindings will all be empty, but it's easier to + -- just use rn_inst_info to change the type appropriately + = do { rn_inst_infos <- mapM rn_inst_info inst_infos + ; return (rn_inst_infos, emptyValBindsOut) } | otherwise - = do { let aux_binds = listToBag (map genAuxBind (rm_dups [] deriv_aux_binds)) - -- Generate any extra not-one-inst-decl-specific binds, + = discardWarnings $ -- Discard warnings about unused bindings etc + do { (rn_gen, dus_gen) <- setOptM Opt_PatternSignatures $ -- Type signatures in patterns + -- are used in the generic binds + rnTopBinds (ValBindsIn gen_binds []) + ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive + + -- Generate and rename any extra not-one-inst-decl-specific binds, -- notably "con2tag" and/or "tag2con" functions. + -- Bring those names into scope before renaming the instances themselves + ; loc <- getSrcSpanM -- Generic loc for shared bindings + ; let aux_binds = listToBag $ map (genAuxBind loc) $ + rm_dups [] $ concat deriv_aux_binds + ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds []) + ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs) + + ; bindLocalNames aux_names $ + do { (rn_aux, _dus) <- rnTopBindsRHS aux_names rn_aux_lhs + ; rn_inst_infos <- mapM rn_inst_info inst_infos + ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen) } } - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds tycl_decls - - -- Rename these extra bindings, discarding warnings about unused bindings etc - -- Type signatures in patterns are used in the generic binds - ; discardWarnings $ - setOptM Opt_PatternSignatures $ - do { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn aux_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) } } where + (inst_infos, deriv_aux_binds) = unzip insts + -- Remove duplicate requests for auxilliary bindings rm_dups acc [] = acc rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs | otherwise = rm_dups (b:acc) bs + + rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived }) + = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived }) + + rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs }) + = -- Bring the right type variables into + -- scope (yuk), and rename the method binds + ASSERT( null sigs ) + bindLocalNames (map Var.varName tyvars) $ + do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds + ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) } + where + (tyvars,_,clas,_) = instanceHead inst + clas_nm = className clas + ----------------------------------------- -mkGenericBinds :: [LTyClDecl Name] -> TcM (LHsBinds RdrName) -mkGenericBinds 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 +mkGenericBinds :: Bool -> TcM (LHsBinds RdrName) +mkGenericBinds is_boot + | is_boot + = return emptyBag + | otherwise + = do { gbl_env <- getGblEnv + ; let tcs = typeEnvTyCons (tcg_type_env gbl_env) ; return (unionManyBags [ mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc ]) } - -- And then only in the ones whose 'has-generics' flag is on + -- We are only interested in the data type declarations, + -- and then only in the ones whose 'has-generics' flag is on + -- The predicate tyConHasGenerics finds both of these \end{code} @@ -407,11 +434,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ------------------------------------------------------------------ deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec) -deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = tv_names, - tcdTyPats = ty_pats })) - = setSrcSpan loc $ - tcAddDeclCtxt decl $ +deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, + tcdTyVars = tv_names, + tcdTyPats = ty_pats })) + = setSrcSpan loc $ -- Use the location of the 'deriving' item + tcAddDeclCtxt decl $ do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names hs_app = nlHsTyConApp tycon_name hs_ty_args -- We get kinding info for the tyvars by typechecking (T a b) @@ -712,7 +739,8 @@ std_class_via_iso clas -- These standard classes can be derived for a newtype new_dfun_name :: Class -> TyCon -> TcM Name new_dfun_name clas tycon -- Just a simple wrapper - = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon) + = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon + ; newDFunName clas [mkTyConApp tycon []] loc } -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list \end{code} @@ -868,9 +896,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs right_arity = length cls_tys + 1 == classArity cls -- Never derive Read,Show,Typeable,Data this way - non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey] + non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++ + typeableClassNames) can_derive_via_isomorphism - = not (getUnique cls `elem` non_iso_classes) + = not (non_iso_class cls) && right_arity -- Well kinded; -- eg not: newtype T ... deriving( ST ) -- because ST needs *2* type params @@ -1111,50 +1140,41 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds) +genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) genInst oflag spec | ds_newtype spec = return (InstInfo { iSpec = mkInstance1 oflag spec , iBinds = NewTypeDerived }, []) | otherwise - = do { fix_env <- getFixityEnv - ; let - inst = mkInstance1 oflag spec - (tyvars,_,clas,[ty]) = instanceHead inst - clas_nm = className clas - (visible_tycon, tyArgs) = tcSplitTyConApp ty + = do { let loc = getSrcSpan (ds_name spec) + inst = mkInstance1 oflag spec + (_,_,clas,[ty]) = instanceHead inst + (visible_tycon, tyArgs) = tcSplitTyConApp ty -- In case of a family instance, we need to use the representation -- tycon (after all, it has the data constructors) ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs - ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon - - -- Bring the right type variables into - -- scope, and rename the method binds - -- It's a bit yukky that we return *renamed* InstInfo, but - -- *non-renamed* auxiliary bindings - ; (rn_meth_binds, _fvs) <- discardWarnings $ - bindLocalNames (map Var.varName tyvars) $ - rnMethodBinds clas_nm (\_ -> []) [] meth_binds + ; fix_env <- getFixityEnv + ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas tycon -- Build the InstInfo ; return (InstInfo { iSpec = inst, - iBinds = VanillaInst rn_meth_binds [] }, + iBinds = VanillaInst meth_binds [] }, aux_binds) } -genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -genDerivBinds clas fix_env tycon +genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +genDerivBinds loc fix_env clas tycon | className clas `elem` typeableClassNames - = (gen_Typeable_binds tycon, []) + = (gen_Typeable_binds loc tycon, []) | otherwise = case assocMaybe gen_list (getUnique clas) of - Just gen_fn -> gen_fn tycon + Just gen_fn -> gen_fn loc tycon Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas) where - gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))] + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))] gen_list = [(eqClassKey, gen_Eq_binds) ,(ordClassKey, gen_Ord_binds) ,(enumClassKey, gen_Enum_binds) @@ -1162,7 +1182,7 @@ genDerivBinds clas fix_env tycon ,(ixClassKey, gen_Ix_binds) ,(showClassKey, gen_Show_binds fix_env) ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds fix_env) + ,(dataClassKey, gen_Data_binds) ] \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 74eb195..98db64c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -600,43 +600,43 @@ But local instance decls includes as well as explicit user written ones. \begin{code} -data InstInfo +data InstInfo a = InstInfo { iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings -- variables scope over the stuff in InstBindings! + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } -iDFunId :: InstInfo -> DFunId +iDFunId :: InstInfo a -> DFunId iDFunId info = instanceDFunId (iSpec info) -data InstBindings +data InstBindings a = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings for the instance methods - [LSig Name] -- User pragmas recorded for generating + (LHsBinds a) -- Bindings for the instance methods + [LSig a] -- User pragmas recorded for generating -- specialised instances | NewTypeDerived -- Used for deriving instances of newtypes, where the -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. -pprInstInfo :: InstInfo -> SDoc +pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] -pprInstInfoDetails :: InstInfo -> SDoc +pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where details (VanillaInst b _) = pprLHsBinds b details NewTypeDerived = text "Derived from the representation type" -simpleInstInfoClsTy :: InstInfo -> (Class, Type) +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of (_, _, cls, [ty]) -> (cls, ty) _ -> panic "simpleInstInfoClsTy" -simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy :: InstInfo a -> Type simpleInstInfoTy info = snd (simpleInstInfoClsTy info) -simpleInstInfoTyCon :: InstInfo -> TyCon +simpleInstInfoTyCon :: InstInfo a -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 4627e22..1a0043a 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -23,9 +23,7 @@ module TcGenDeriv ( gen_Show_binds, gen_Data_binds, gen_Typeable_binds, - genAuxBind, - - con2tag_RDR, tag2con_RDR, maxtag_RDR + genAuxBind ) where #include "HsVersions.h" @@ -147,12 +145,10 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Eq_binds tycon +gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Eq_binds loc tycon = (method_binds, aux_binds) where - tycon_loc = getSrcSpan tycon - (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) @@ -173,8 +169,8 @@ gen_Eq_binds tycon | otherwise = [GenCon2Tag tycon] method_binds = listToBag [ - mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( + mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] ------------------------------------------------------------------ @@ -295,9 +291,9 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat JJQC-30-Nov-1997 \begin{code} -gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Ord_binds tycon +gen_Ord_binds loc tycon | Just (con, prim_tc) <- primWrapperType_maybe tycon = gen_PrimOrd_binds con prim_tc @@ -306,12 +302,10 @@ gen_Ord_binds tycon -- `AndMonoBinds` compare -- The default declaration in PrelBase handles this where - tycon_loc = getSrcSpan tycon - -------------------------------------------------------------------- aux_binds | single_con_type = [] | otherwise = [GenCon2Tag tycon] - compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches) + compare = L loc (mkFunBind (L loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) @@ -331,7 +325,7 @@ gen_Ord_binds tycon | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullarySrcDataCon tycon_data_cons - cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match + cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match cmp_eq_match | isEnumerationTyCon tycon -- We know the tags are equal, so if it's an enumeration TyCon, @@ -468,8 +462,8 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Enum_binds tycon +gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Enum_binds loc tycon = (method_binds, aux_binds) where method_binds = listToBag [ @@ -482,11 +476,10 @@ gen_Enum_binds tycon ] aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] - tycon_loc = getSrcSpan tycon - occ_nm = getOccString tycon + occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $ + = mk_easy_FunBind loc succ_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -496,7 +489,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $ + = mk_easy_FunBind loc pred_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -506,7 +499,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $ + = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -514,7 +507,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $ + = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -523,7 +516,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $ + = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -536,7 +529,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $ + = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -548,8 +541,8 @@ gen_Enum_binds tycon %************************************************************************ \begin{code} -gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Bounded_binds tycon +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Bounded_binds loc tycon | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], []) | otherwise @@ -557,11 +550,10 @@ gen_Bounded_binds tycon (listToBag [ min_bound_1con, max_bound_1con ], []) where data_cons = tyConDataCons tycon - tycon_loc = getSrcSpan tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -571,9 +563,9 @@ gen_Bounded_binds tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind tycon_loc minBound_RDR $ + min_bound_1con = mkVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind tycon_loc maxBound_RDR $ + max_bound_1con = mkVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -636,21 +628,19 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Ix_binds tycon +gen_Ix_binds loc tycon | isEnumerationTyCon tycon = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) | otherwise = (single_con_ixes, [GenCon2Tag tycon]) where - tycon_loc = getSrcSpan tycon - -------------------------------------------------------------- enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_range - = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -659,7 +649,7 @@ gen_Ix_binds tycon (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index - = mk_easy_FunBind tycon_loc unsafeIndex_RDR + = mk_easy_FunBind loc unsafeIndex_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( @@ -675,7 +665,7 @@ gen_Ix_binds tycon ) enum_inRange - = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -708,7 +698,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range - = mk_easy_FunBind tycon_loc range_RDR + = mk_easy_FunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ nlHsDo ListComp stmts con_expr where @@ -720,7 +710,7 @@ gen_Ix_binds tycon ---------------- single_con_index - = mk_easy_FunBind tycon_loc unsafeIndex_RDR + = mk_easy_FunBind loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] -- We need to reverse the order we consider the components in @@ -746,7 +736,7 @@ gen_Ix_binds tycon ------------------ single_con_inRange - = mk_easy_FunBind tycon_loc inRange_RDR + = mk_easy_FunBind loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] $ foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) @@ -800,9 +790,9 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Read_binds get_fixity tycon +gen_Read_binds get_fixity loc tycon = (listToBag [read_prec, default_readlist, default_readlistprec], []) where ----------------------------------------------------------------------- @@ -813,7 +803,6 @@ gen_Read_binds get_fixity tycon = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- - loc = getSrcSpan tycon data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons @@ -953,17 +942,16 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Show_binds get_fixity tycon +gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where - tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- - show_list = mkVarBind tycon_loc showList_RDR + show_list = mkVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- - shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) + shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) where pats_etc data_con | nullary_con = -- skip the showParen junk... @@ -1084,15 +1072,14 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: TyCon -> LHsBinds RdrName -gen_Typeable_binds tycon +gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds loc tycon = unitBag $ - mk_easy_FunBind tycon_loc + mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where - tycon_loc = getSrcSpan tycon tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) mk_typeOf_RDR :: TyCon -> RdrName @@ -1138,23 +1125,22 @@ we generate dataTypeOf _ = $dT \begin{code} -gen_Data_binds :: FixityEnv +gen_Data_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, -- The method bindings DerivAuxBinds) -- Auxiliary bindings -gen_Data_binds _ tycon +gen_Data_binds loc tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors DerivAuxBind datatype_bind : map mk_con_bind data_cons) where - tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon data_cons = tyConDataCons tycon n_cons = length data_cons one_constr = n_cons == 1 ------------ gfoldl - gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) where @@ -1164,7 +1150,7 @@ gen_Data_binds _ tycon mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_FunBind tycon_loc + gunfold_bind = mk_FunBind loc gunfold_RDR [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], gunfold_rhs)] @@ -1187,21 +1173,20 @@ gen_Data_binds _ tycon tag = dataConTag dc ------------ toConstr - toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) + toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons) to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc)) ------------ dataTypeOf dataTypeOf_bind = mk_easy_FunBind - tycon_loc + loc dataTypeOf_RDR [nlWildPat] (nlHsVar data_type_name) ------------ $dT - - data_type_name = mkDerivedRdrName tycon_name mkDataTOcc + data_type_name = mkAuxBinderName tycon_name mkDataTOcc datatype_bind = mkVarBind - tycon_loc + loc data_type_name ( nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) @@ -1211,10 +1196,10 @@ gen_Data_binds _ tycon ------------ $cT1 etc - mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc + mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc mk_con_bind dc = DerivAuxBind $ mkVarBind - tycon_loc + loc (mk_constr_name dc) (nlHsApps mkConstr_RDR (constr_args dc)) constr_args dc = @@ -1262,21 +1247,20 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBind :: DerivAuxBind -> LHsBind RdrName +genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName -genAuxBind (DerivAuxBind bind) +genAuxBind _loc (DerivAuxBind bind) = bind -genAuxBind (GenCon2Tag tycon) +genAuxBind loc (GenCon2Tag tycon) | lots_of_constructors - = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] + = mk_FunBind loc rdr_name [([], get_tag_rhs)] | otherwise - = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) + = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon)) where rdr_name = con2tag_RDR tycon - tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) -- We can't use gerRdrName because that makes an Exact RdrName @@ -1285,7 +1269,7 @@ genAuxBind (GenCon2Tag tycon) -- Give a signature to the bound variable, so -- that the case expression generated by getTag is -- monomorphic. In the push-enter model we get better code. - get_tag_rhs = noLoc $ ExprWithTySig + get_tag_rhs = L loc $ ExprWithTySig (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) @@ -1302,16 +1286,16 @@ genAuxBind (GenCon2Tag tycon) mk_stuff con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -genAuxBind (GenTag2Con tycon) - = mk_FunBind (getSrcSpan tycon) rdr_name +genAuxBind loc (GenTag2Con tycon) + = mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) (nlHsTyVar (getRdrName tycon))))] where rdr_name = tag2con_RDR tycon -genAuxBind (GenMaxTag tycon) - = mkVarBind (getSrcSpan tycon) rdr_name +genAuxBind loc (GenMaxTag tycon) + = mkVarBind loc rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where rdr_name = maxtag_RDR tycon @@ -1559,7 +1543,13 @@ tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name tycon fun = mkDerivedRdrName (tyConName tycon) fun +mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun + +mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName +mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent)) +-- Was: mkDerivedRdrName name occ_fun, which made an original name +-- But: (a) that does not work well for standalone-deriving +-- (b) an unqualified name is just fine, provided it can't clash with user code \end{code} s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 091296a..3a8326f 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -166,8 +166,8 @@ tcHsQuantifiedType tv_names hs_ty ; return (tvs, ty) } } -- Used for the deriving(...) items -tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) -tcHsDeriv = addLocM (tc_hs_deriv []) +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) +tcHsDeriv = tc_hs_deriv [] tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name -> TcM ([TyVar], Class, [Type]) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index df43f53..1f800d9 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -136,7 +136,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> [LInstDecl Name] -- Source code instance decls -> [LDerivDecl Name] -- Source code stand-alone deriving decls -> TcM (TcGblEnv, -- The full inst env - [InstInfo], -- Source-code instance decls to process; + [InstInfo Name], -- Source-code instance decls to process; -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances @@ -215,7 +215,7 @@ assocInClassErr name = ptext (sLit "Associated type") <+> quotes (ppr name) <+> ptext (sLit "must be inside a class instance") -addInsts :: [InstInfo] -> TcM a -> TcM a +addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside @@ -230,7 +230,7 @@ addFamInsts tycons thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo], [TyThing]) -- [] if there was an error + -> TcM ([InstInfo Name], [TyThing]) -- [] if there was an error -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -238,7 +238,7 @@ tcLocalInstDecl1 :: LInstDecl Name tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) = -- Prime error recovery, set source location recoverM (return ([], [])) $ - setSrcSpan loc $ + setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -258,7 +258,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys loc + ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) + -- Dfun location is that of instance *header* ; overlap_flag <- getOverlapFlag ; let (eq_theta,dict_theta) = partition isEqPred theta theta' = eq_theta ++ dict_theta @@ -371,7 +372,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ \begin{code} -tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] +tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] -> TcM (LHsBinds Id, TcLclEnv) -- (a) From each class declaration, -- generate any default-method bindings @@ -457,7 +458,7 @@ is the @dfun_theta@ below. \begin{code} -tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun ------------------------ @@ -582,7 +583,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) dfun_id = instanceDFunId ispec rigid_info = InstSkol inst_ty = idType dfun_id - loc = srcLocSpan (getSrcLoc dfun_id) + loc = getSrcSpan dfun_id in -- Prime error recovery recoverM (return emptyLHsBinds) $ -- 1.7.10.4