Several fixes to 'deriving' including Trac #2378
authorsimonpj@microsoft.com <unknown>
Tue, 1 Jul 2008 12:09:08 +0000 (12:09 +0000)
committersimonpj@microsoft.com <unknown>
Tue, 1 Jul 2008 12:09:08 +0000 (12:09 +0000)
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
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs

index 8b43ad6..1fd8706 100644 (file)
@@ -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)),
index 03638b1..7a2954a 100644 (file)
@@ -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}
 
index 74eb195..98db64c 100644 (file)
@@ -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 -> 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 -> 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 -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
                            (_, _, cls, [ty]) -> (cls, ty)
                            _ -> panic "simpleInstInfoClsTy"
 
-simpleInstInfoTy :: InstInfo -> Type
+simpleInstInfoTy :: InstInfo -> Type
 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
 
-simpleInstInfoTyCon :: InstInfo -> TyCon
+simpleInstInfoTyCon :: InstInfo -> 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)
index 4627e22..1a0043a 100644 (file)
@@ -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
index 091296a..3a8326f 100644 (file)
@@ -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])
index df43f53..1f800d9 100644 (file)
@@ -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)             $