Commit 9319fbaf authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent cb906a12
......@@ -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)),
......
......@@ -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}
......
......@@ -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)
......
......@@ -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