Permalink
Browse files

Refactor the implementation.

  • Loading branch information...
1 parent 3a9fddd commit acc2451d5df3a5523a362e029b1b6d63e3fe3196 @dreixel dreixel committed Oct 4, 2011
Showing with 217 additions and 169 deletions.
  1. +70 −53 compiler/typecheck/TcDeriv.lhs
  2. +145 −114 compiler/typecheck/TcGenDeriv.lhs
  3. +2 −2 compiler/types/Generics.lhs
View
123 compiler/typecheck/TcDeriv.lhs 100644 → 100755
@@ -314,16 +314,20 @@ tcDeriving tycl_decls inst_decls deriv_decls
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
- ; deriv1 <- flatMapBagM (genInst True overlap_flag) (listToBag given_specs)
- ; let (insts,_) = partitionBagWith unDerivInst deriv1
+ ; insts1 <- mapM (genInst True overlap_flag) given_specs
+-- ; let (insts,_) = partitionBagWith unDerivInst deriv1
- ; final_specs <- extendLocalInstEnv (map iSpec (bagToList insts)) $
- inferInstanceContexts overlap_flag infer_specs
+ ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
+ inferInstanceContexts overlap_flag infer_specs
- ; deriv2 <- flatMapBagM (genInst False overlap_flag) (listToBag final_specs)
+ ; insts2 <- mapM (genInst False overlap_flag) final_specs
- ; (inst_info, rn_binds, rn_dus)
- <- renameDeriv is_boot (deriv1 `unionBags` deriv2)
+ ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
+ ; loc <- getSrcSpanM
+ ; let (binds, newTyCons, famInsts, extraInstances) =
+ genAuxBinds loc (rm_dups (unionManyBags deriv_stuff))
+ ; (inst_info, rn_binds, rn_dus) <-
+ renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
@@ -332,7 +336,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-}
-
+{-
; let unGenBinds (DerivGenMetaTyCons x) = Left (Right x)
unGenBinds (DerivGenRepTyCon x) = Left (Left x)
unGenBinds x = Right x
@@ -341,14 +345,19 @@ tcDeriving tycl_decls inst_decls deriv_decls
(repTyConsB, repMetaTysB) = partitionBagWith id genBinds
(repTyCons, repMetaTys) = (bagToList repTyConsB, bagToList repMetaTysB)
all_tycons = map ATyCon (repTyCons ++ concat (map metaTyCons2TyCons repMetaTys))
-
+-}
+ ; let all_tycons = map ATyCon (bagToList newTyCons)
; gbl_env <- tcExtendGlobalEnv all_tycons $
tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
- tcExtendLocalFamInstEnv (map mkLocalFamInst repTyCons) $
+ tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
where
+ -- Remove duplicate requests for auxilliary bindings
+ rm_dups = foldrBag dup_check emptyBag
+ dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
+
ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
-> [MetaTyCons] -- ^ Empty data constructors
-> [TyCon] -- ^ Rep type family instances
@@ -372,37 +381,38 @@ tcDeriving tycl_decls inst_decls deriv_decls
renameDeriv :: Bool
- -> BagDerivStuff --[(InstInfo RdrName, DerivAuxBinds)]
+ -> [InstInfo RdrName]
+ -> Bag (LHsBind RdrName, LSig RdrName)
-> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
-renameDeriv is_boot insts
+renameDeriv is_boot inst_infos bagBinds
| 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, fvs) <- mapAndUnzipBagM rn_inst_info inst_infos
- ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs (bagToList fvs))) }
+ = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
+ ; return ( listToBag rn_inst_infos
+ , emptyValBindsOut, usesOnly (plusFVs fvs)) }
| otherwise
= discardWarnings $ -- Discard warnings about unused bindings etc
do {
-- 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
- ; (aux_binds, aux_sigs) <- genAuxBinds loc (rm_dups other_binds)
+-- loc <- getSrcSpanM -- Generic loc for shared bindings
+ ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; bindLocalNames (collectHsValBinders rn_aux_lhs) $
do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
- ; (rn_inst_infos, fvs_insts) <- mapAndUnzipBagM rn_inst_info inst_infos
- ; return (rn_inst_infos, rn_aux,
- dus_aux `plusDU` usesOnly (plusFVs (bagToList fvs_insts))) } }
+ ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+ ; return (listToBag rn_inst_infos, rn_aux,
+ dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
where
- (inst_infos, other_binds) = partitionBagWith unDerivInst insts
-
- -- Remove duplicate requests for auxilliary bindings
- rm_dups = foldrBag dup_check emptyBag
- dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
+{-
+ --(inst_infos, other_binds) = partitionBagWith unDerivInst insts
+ (inst_infos, other_binds) = unzip insts
+-}
rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
@@ -421,10 +431,11 @@ renameDeriv is_boot insts
where
(tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas
-
+{-
unDerivInst :: DerivStuff -> Either (InstInfo RdrName) DerivStuff
unDerivInst (DerivInst x) = Left x
unDerivInst x = Right x
+-}
\end{code}
Note [Newtype deriving and unused constructors]
@@ -456,16 +467,6 @@ stored in NewTypeDerived.
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
--- Make the "extras" for the generic representation
-mkGenDerivExtras :: TyCon -> Module
- -> TcRn BagDerivStuff
-mkGenDerivExtras tc mod = do
- { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
- ; metaInsts <- genDtMeta (tc, metaTyCons)
- ; return ( unitBag (DerivGenMetaTyCons metaTyCons)
- `unionBags` unitBag (DerivGenRepTyCon rep0TyInst)
- `unionBags` metaInsts) }
-
makeDerivSpecs :: Bool
-> [LTyClDecl Name]
-> [LInstDecl Name]
@@ -1469,41 +1470,45 @@ the renamer. What a great hack!
--
genInst :: Bool -- True <=> standalone deriving
-> OverlapFlag
- -> DerivSpec -> TcM BagDerivStuff
+ -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
genInst standalone_deriv oflag
spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype
, ds_name = name, ds_cls = clas })
| is_newtype
- = return $ unitBag $ DerivInst $
- InstInfo { iSpec = inst_spec
- , iBinds = NewTypeDerived co rep_tycon }
+ = return (InstInfo { iSpec = inst_spec
+ , iBinds = NewTypeDerived co rep_tycon }, emptyBag)
| otherwise
= do { fix_env <- getFixityEnv
- ; let { loc = getSrcSpan name
- ; deriv_stuff = genDerivStuff loc fix_env clas rep_tycon
+ ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
+ fix_env clas name rep_tycon
+ ; let {
+{-
; (meth_binds', aux_binds) = partitionBag isDerivHsBind deriv_stuff
; meth_binds = mapBag unDerivHsBind meth_binds'
+-}
-- In case of a family instance, we need to use the representation
-- tycon (after all, it has the data constructors)
; inst_info = InstInfo { iSpec = inst_spec
, iBinds = VanillaInst meth_binds []
standalone_deriv } }
+{-
-- Generate the extra representation types and instances needed for a
-- `Generic` instance
; generics_extras <- if classKey clas == genClassKey
- then mkGenDerivExtras rep_tycon (nameModule name)
+ then gen_Generic_binds rep_tycon (nameModule name)
else return emptyBag
-
- ; return (unitBag (DerivInst inst_info)
- `unionBags` aux_binds `unionBags` generics_extras) }
+-}
+ ; return ( inst_info, deriv_stuff) }
where
+{-
isDerivHsBind (DerivHsBind _) = True
isDerivHsBind _ = False
unDerivHsBind (DerivHsBind x) = x
unDerivHsBind _ = panic "unDerivHsBind"
+-}
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkAxInstCo co_con rep_tc_args
@@ -1521,18 +1526,21 @@ genInst standalone_deriv oflag
-- co2 : R1:N (b,b) ~ Tree (b,b)
-- co : N [(b,b)] ~ Tree (b,b)
-genDerivStuff :: SrcSpan -> FixityEnv -> Class -> TyCon
- -> BagDerivStuff -- (LHsBinds RdrName, DerivAuxBinds)
-genDerivStuff loc fix_env clas tycon
+genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
+ -> TcM (LHsBinds RdrName, BagDerivStuff)
+genDerivStuff loc fix_env clas name tycon
| className clas `elem` typeableClassNames
- = gen_Typeable_binds loc tycon
+ = return (gen_Typeable_binds loc tycon, emptyBag)
+
+ | classKey clas == genClassKey
+ = gen_Generic_binds tycon (nameModule name)
| otherwise
= case assocMaybe gen_list (getUnique clas) of
- Just gen_fn -> gen_fn loc tycon
+ Just gen_fn -> return (gen_fn loc tycon)
Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
where
- gen_list :: [(Unique, SrcSpan -> TyCon -> BagDerivStuff)]
+ gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
@@ -1544,7 +1552,6 @@ genDerivStuff loc fix_env clas tycon
,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds)
- ,(genClassKey, genGenericBinds)
]
\end{code}
@@ -1566,9 +1573,19 @@ For the generic representation we need to generate:
@genGenericAll@ does all of them
\begin{code}
+gen_Generic_binds :: TyCon -> Module
+ -> TcM (LHsBinds RdrName, BagDerivStuff)
+gen_Generic_binds tc mod = do
+ { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
+ ; metaInsts <- genDtMeta (tc, metaTyCons)
+ ; return ( mkBindsRep tc
+ , (DerivFamInst rep0TyInst)
+ `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
+ `unionBags` metaInsts)) }
+{-
genGenericBinds :: SrcSpan -> TyCon -> BagDerivStuff
genGenericBinds _ tc = mapBag DerivHsBind $ mkBindsRep tc
-
+-}
genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
genGenericRepExtras tc mod =
do uniqS <- newUniqueSupply
View
259 compiler/typecheck/TcGenDeriv.lhs 100644 → 100755
@@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation.
\begin{code}
module TcGenDeriv (
- BagDerivStuff, DerivStuff(..),
+ BagDerivStuff, DerivStuff(..), isDupAux,
gen_Bounded_binds,
gen_Enum_binds,
@@ -28,8 +28,8 @@ module TcGenDeriv (
deepSubtypesContaining, foldDataConArgs,
gen_Foldable_binds,
gen_Traversable_binds,
- genAuxBinds, isDupAux,
- ordOpTbl, boxConTbl
+ genAuxBind, genAuxBinds,
+ ordOpTbl, boxConTbl
) where
#include "HsVersions.h"
@@ -62,44 +62,56 @@ import FastString
import Bag
import Fingerprint
import Constants
-import Generics (MetaTyCons)
import TcEnv (InstInfo)
import Data.List ( partition, intersperse )
\end{code}
\begin{code}
+{-
+type DerivAuxBinds = [DerivAuxBind]
+
+data DerivAuxBind -- Please add these auxiliary top-level bindings
+ = DerivCon2Tag TyCon -- The con2Tag for given TyCon
+ | DerivTag2Con TyCon -- ...ditto tag2Con
+ | DerivMaxTag TyCon -- ...and maxTag
+ -- All these generate ZERO-BASED tag operations
+ -- I.e first constructor has tag 0
+
+ -- Scrap your boilerplate
+ | MkDataCon DataCon -- For constructor C we get $cC :: Constr
+ | MkTyCon TyCon -- For tycon T we get $tT :: DataType
+-}
type BagDerivStuff = Bag DerivStuff
-data DerivStuff -- Please add these auxiliary top-level bindings
+data DerivStuff -- Please add these auxiliary stuff
= DerivCon2Tag TyCon -- The con2Tag for given TyCon
| DerivTag2Con TyCon -- ...ditto tag2Con
| DerivMaxTag TyCon -- ...and maxTag
-- All these generate ZERO-BASED tag operations
-- I.e first constructor has tag 0
-
-- Generics
- | DerivGenMetaTyCons MetaTyCons -- New data types
- | DerivGenRepTyCon TyCon -- New type family instances
+ | DerivTyCon TyCon -- New data types
+ | DerivFamInst TyCon -- New type family instances
- | DerivHsBind (LHsBind RdrName) -- Yes, but not for the method bindings
- -- Rather for top-level auxiliary bindings
+ | DerivHsBind (LHsBind RdrName) -- New top-level auxiliary bindings
+ | DerivInst (InstInfo RdrName) -- New, auxiliary instances
-- Scrap your boilerplate (replaced by DerivHsBind)
-- | DerivDataCon DataCon -- For constructor C we get $cC :: Constr
-- | DerivTyCon TyCon -- For tycon T we get $tT :: DataType
+
+
isDupAux :: DerivStuff -> DerivStuff -> Bool
-isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
-isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
-isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
-isDupAux (DerivDataCon dc1) (DerivDataCon dc2) = dc1 == dc2
-isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
--- We are certain we do not introduce duplicates for the other cases
-isDupAux _ _ = False
-
+isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
+isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
+isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
+isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
+isDupAux (DerivFamInst tc1) (DerivFamInst tc2) = tc1 == tc2
+isDupAux _ _ = False
\end{code}
@@ -178,9 +190,9 @@ instance ... Eq (Foo ...) where
\begin{code}
-gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Eq_binds loc tycon
- = method_binds `unionBags` aux_binds
+ = (method_binds, aux_binds)
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
@@ -199,9 +211,9 @@ gen_Eq_binds loc tycon
(genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds | no_nullary_cons = emptyBag
- | otherwise = unitBag (DerivCon2Tag tycon)
+ | otherwise = unitBag $ DerivCon2Tag tycon
- method_binds = listToBag (map DerivHsBind [eq_bind, ne_bind])
+ method_binds = listToBag [eq_bind, ne_bind]
eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
@@ -336,19 +348,15 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
-gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Ord_binds loc tycon
| null tycon_data_cons -- No data-cons => invoke bale-out case
- = unitBag $ DerivHsBind $ mk_FunBind loc compare_RDR []
+ = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
| otherwise
- = unitBag (mkOrdOp OrdCompare)
- `unionBags`
- other_ops
- `unionBags`
- aux_binds
+ = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
where
aux_binds | single_con_type = emptyBag
- | otherwise = unitBag (DerivCon2Tag tycon)
+ | otherwise = unitBag $ DerivCon2Tag tycon
-- Note [Do not rely on compare]
other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
@@ -371,11 +379,9 @@ gen_Ord_binds loc tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
- mkOrdOp :: OrdOp -> DerivStuff --LHsBind RdrName
+ mkOrdOp :: OrdOp -> LHsBind RdrName
-- Returns a binding op a b = ... compares a and b according to op ....
- mkOrdOp op = DerivHsBind $
- mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
- (mkOrdOpRhs op)
+ mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
@@ -565,18 +571,18 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
-gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Enum_binds loc tycon
- = method_binds `unionBags` aux_binds
+ = (method_binds, aux_binds)
where
- method_binds = listToBag (map DerivHsBind [
+ method_binds = listToBag [
succ_enum,
pred_enum,
to_enum,
enum_from,
enum_from_then,
from_enum
- ])
+ ]
aux_binds = listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
occ_nm = getOccString tycon
@@ -644,13 +650,13 @@ gen_Enum_binds loc tycon
%************************************************************************
\begin{code}
-gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Bounded_binds loc tycon
| isEnumerationTyCon tycon
- = listToBag (map DerivHsBind [min_bound_enum, max_bound_enum])
+ = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
= ASSERT(isSingleton data_cons)
- (listToBag (map DerivHsBind [min_bound_1con, max_bound_1con]))
+ (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
where
data_cons = tyConDataCons tycon
@@ -731,17 +737,16 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
-gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Ix_binds loc tycon
| isEnumerationTyCon tycon
- = enum_ixes `unionBags`
- listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
+ = (enum_ixes, listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
| otherwise
- = single_con_ixes `unionBags` unitBag (DerivCon2Tag tycon)
+ = (single_con_ixes, unitBag (DerivCon2Tag tycon))
where
--------------------------------------------------------------
- enum_ixes = listToBag (map DerivHsBind [enum_range, enum_index, enum_inRange])
+ enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range
= mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
@@ -780,8 +785,8 @@ gen_Ix_binds loc tycon
))))
--------------------------------------------------------------
- single_con_ixes = listToBag (map DerivHsBind
- [single_con_range, single_con_index, single_con_inRange])
+ single_con_ixes
+ = listToBag [single_con_range, single_con_index, single_con_inRange]
data_con
= case tyConSingleDataCon_maybe tycon of -- just checking...
@@ -891,10 +896,10 @@ instance Read T where
\begin{code}
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
+gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Read_binds get_fixity loc tycon
- = listToBag (map DerivHsBind [read_prec, default_readlist, default_readlistprec])
+ = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
default_readlist
@@ -1060,10 +1065,10 @@ Example
-- the most tightly-binding operator
\begin{code}
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
+gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Show_binds get_fixity loc tycon
- = listToBag (map DerivHsBind [shows_prec, show_list])
+ = (listToBag [shows_prec, show_list], emptyBag)
where
-----------------------------------------------------------------------
show_list = mkHsVarBind loc showList_RDR
@@ -1192,9 +1197,9 @@ we generate
We are passed the Typeable2 class as well as T
\begin{code}
-gen_Typeable_binds :: SrcSpan -> TyCon -> BagDerivStuff --LHsBinds RdrName
+gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
gen_Typeable_binds loc tycon
- = unitBag $ DerivHsBind $
+ = unitBag $
mk_easy_FunBind loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat]
@@ -1270,17 +1275,57 @@ we generate
\begin{code}
-gen_Data_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Data_binds :: SrcSpan
+ -> TyCon
+ -> (LHsBinds RdrName, -- The method bindings
+ BagDerivStuff) -- Auxiliary bindings
gen_Data_binds loc tycon
- = listToBag (map DerivHsBind [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind])
- `unionBags` gcast_binds
- -- Auxiliary definitions: the data type and constructors
- `unionBags` (listToBag (DerivTyCon tycon : map DerivDataCon data_cons))
+ = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+ `unionBags` gcast_binds,
+ -- Auxiliary definitions: the data type and constructors
+ listToBag ( DerivHsBind (fst genDataTyCon)
+ : map (DerivHsBind . fst . genDataDataCon) data_cons))
+ -- JPM: We are dropping the signatures. Is this a problem?
where
data_cons = tyConDataCons tycon
n_cons = length data_cons
one_constr = n_cons == 1
+ genDataTyCon :: (LHsBind RdrName, LSig RdrName)
+ genDataTyCon -- $dT
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig [L loc rdr_name] sig_ty))
+ where
+ rdr_name = mk_data_type_name tycon
+ sig_ty = nlHsTyVar dataType_RDR
+ constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+ rhs = nlHsVar mkDataType_RDR
+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
+ `nlHsApp` nlList constrs
+
+ genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
+ genDataDataCon dc -- $cT1 etc
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig [L loc rdr_name] sig_ty))
+ where
+ rdr_name = mk_constr_name dc
+ sig_ty = nlHsTyVar constr_RDR
+ rhs = nlHsApps mkConstr_RDR constr_args
+
+ constr_args
+ = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
+ nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
+ nlHsLit (mkHsString (occNameString dc_occ)), -- String name
+ nlList labels, -- Field labels
+ nlHsVar fixity] -- Fixity
+
+ labels = map (nlHsLit . mkHsString . getOccString)
+ (dataConFieldLabels dc)
+ dc_occ = getOccName dc
+ is_infix = isDataSymOcc dc_occ
+ fixity | is_infix = infix_RDR
+ | otherwise = prefix_RDR
+
------------ gfoldl
gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
@@ -1333,7 +1378,7 @@ gen_Data_binds loc tycon
| tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
| otherwise = emptyBag
mk_gcast dataCast_RDR gcast_RDR
- = unitBag (DerivHsBind $ mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
+ = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
(nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
@@ -1432,12 +1477,12 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
$(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
\begin{code}
-gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Functor_binds loc tycon
- = unitBag fmap_bind
+ = (unitBag fmap_bind, emptyBag)
where
data_cons = tyConDataCons tycon
- fmap_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
+ fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
@@ -1603,13 +1648,13 @@ Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
\begin{code}
-gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Foldable_binds loc tycon
- = unitBag foldr_bind
+ = (unitBag foldr_bind, emptyBag)
where
data_cons = tyConDataCons tycon
- foldr_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
+ foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
where
@@ -1655,13 +1700,13 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
instead of: traverse f (T x y) = T x <$> f y
\begin{code}
-gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Traversable_binds loc tycon
- = unitBag traverse_bind
+ = (unitBag traverse_bind, emptyBag)
where
data_cons = tyConDataCons tycon
- traverse_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
+ traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
eqns = map traverse_eqn data_cons
traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
@@ -1755,51 +1800,37 @@ genAuxBind loc (DerivMaxTag tycon)
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
-genAuxBind loc (DerivTyCon tycon) -- $dT
- = (mkHsVarBind loc rdr_name rhs,
- L loc (TypeSig [L loc rdr_name] sig_ty))
- where
- rdr_name = mk_data_type_name tycon
- sig_ty = nlHsTyVar dataType_RDR
- constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
- rhs = nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
- `nlHsApp` nlList constrs
-
-genAuxBind loc (DerivDataCon dc) -- $cT1 etc
- = (mkHsVarBind loc rdr_name rhs,
- L loc (TypeSig [L loc rdr_name] sig_ty))
- where
- rdr_name = mk_constr_name dc
- sig_ty = nlHsTyVar constr_RDR
- rhs = nlHsApps mkConstr_RDR constr_args
-
- constr_args
- = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
- nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
- nlHsLit (mkHsString (occNameString dc_occ)), -- String name
- nlList labels, -- Field labels
- nlHsVar fixity] -- Fixity
-
- labels = map (nlHsLit . mkHsString . getOccString)
- (dataConFieldLabels dc)
- dc_occ = getOccName dc
- is_infix = isDataSymOcc dc_occ
- fixity | is_infix = infix_RDR
- | otherwise = prefix_RDR
-
--- We know we do not call genAuxBind with the generics stuff
-genAuxBind _ _ = panic "genAuxBind"
-
-genAuxBinds :: Monad m => SrcSpan -> BagDerivStuff -> m ( Bag (LHsBind RdrName)
- , Bag (LSig RdrName))
-genAuxBinds loc bs = mapAndUnzipBagM (return . genAuxBind loc) auxBinds where
- partf x@(DerivGenMetaTyCons _) = Left x
- partf x@(DerivGenRepTyCon _) = Left x
- partf x@(DerivInst _) = Left x
- partf x@(DerivHsBind _) = Left x
- partf x = Right x
- (_, auxBinds) = partitionBagWith partf bs
+genAuxBind loc _ = panic "genAuxBind"
+
+genAuxBinds :: SrcSpan -> BagDerivStuff
+ -> ( Bag (LHsBind RdrName, LSig RdrName)
+ , Bag TyCon
+ , Bag TyCon
+ , Bag (InstInfo RdrName))
+{-
+genAuxBinds loc = mapBag (genAuxBind loc) . filterBag (not . isGen)
+ isGen (DerivCon2Tag _) = True
+ isGen (DerivTag2Con _) = True
+ isGen (DerivMaxTag _) = True
+ isGen (DerivTyCon t) = = False
+ isGen (DerivFamInst t) = = False
+-}
+genAuxBinds loc s = foldrBag f (emptyBag, emptyBag, emptyBag, emptyBag) s where
+ f :: DerivStuff
+ -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
+ -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
+ f x@(DerivCon2Tag _) = add1 (genAuxBind loc x)
+ f x@(DerivTag2Con _) = add1 (genAuxBind loc x)
+ f x@(DerivMaxTag _) = add1 (genAuxBind loc x)
+ f (DerivTyCon t) = add2 t
+ f (DerivFamInst t) = add3 t
+ f (DerivInst i) = add4 i
+ f _ = id
+
+ add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
+ add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
+ add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
+ add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
mk_data_type_name :: TyCon -> RdrName -- "$tT"
mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
View
4 compiler/types/Generics.lhs 100644 → 100755
@@ -224,8 +224,8 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
instance Outputable MetaTyCons where
ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
-metaTyCons2TyCons :: MetaTyCons -> [TyCon]
-metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
+metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
-- Bindings for Datatype, Constructor, and Selector instances

0 comments on commit acc2451

Please sign in to comment.