Commit 4830c8c2 authored by dreixel's avatar dreixel
Browse files

Some more refactoring.

parent 3f50b5b9
......@@ -315,7 +315,6 @@ tcDeriving tycl_decls inst_decls deriv_decls
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
; insts1 <- mapM (genInst True overlap_flag) given_specs
-- ; let (insts,_) = partitionBagWith unDerivInst deriv1
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
inferInstanceContexts overlap_flag infer_specs
......@@ -331,21 +330,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds undefined undefined undefined))
(ddump_deriving inst_info rn_binds newTyCons famInsts extraInstances))
{-
; 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
-- JPM: All this partitioning should perhaps be refactored
(genBinds, _) = partitionBagWith unGenBinds (deriv1 `unionBags` deriv2)
(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) $
......@@ -359,23 +349,23 @@ tcDeriving tycl_decls inst_decls deriv_decls
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
-> [[(InstInfo RdrName, BagDerivStuff)]]
-> Bag TyCon -- ^ Empty data constructors
-> Bag TyCon -- ^ Rep type family instances
-> Bag (InstInfo RdrName)
-- ^ Instances for the repMetaTys
-> SDoc
ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
= hang (ptext (sLit "Derived instances"))
= hang (ptext (sLit "Derived instances:"))
2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
$$ ppr extra_binds)
$$ hangP "Generic representation" (
hangP "Generated datatypes for meta-information"
(vcat (map ppr repMetaTys))
$$ hangP "Generic representation:" (
hangP "Generated datatypes for meta-information:"
(vcat (map ppr (bagToList repMetaTys)))
-- The Outputable instance for TyCon unfortunately only prints the name...
$$ hangP "Representation types"
(vcat (map ppr repTyCons))
$$ hangP "Meta-information instances"
(vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
$$ hangP "Representation types:"
(vcat (map ppr (bagToList repTyCons)))
$$ hangP "Meta-information instances:"
(vcat (map pprInstInfoDetails (bagToList metaInsts))))
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
......@@ -395,10 +385,8 @@ renameDeriv is_boot inst_infos bagBinds
| 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
-- Bring the extra deriving stuff into scope
-- before renaming the instances themselves
; (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
......@@ -409,10 +397,6 @@ renameDeriv is_boot inst_infos bagBinds
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
where
{-
--(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 })
......@@ -431,11 +415,6 @@ renameDeriv is_boot inst_infos bagBinds
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]
......@@ -1483,37 +1462,17 @@ genInst standalone_deriv oflag
= do { fix_env <- getFixityEnv
; (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 gen_Generic_binds rep_tycon (nameModule name)
else return emptyBag
-}
; let inst_info = InstInfo { iSpec = inst_spec
, iBinds = VanillaInst meth_binds []
standalone_deriv }
; 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
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
co = co1 `mkTransCo` co2
id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
......@@ -1537,22 +1496,22 @@ genDerivStuff loc fix_env clas name tycon
| otherwise
= case assocMaybe gen_list (getUnique clas) of
Just gen_fn -> return (gen_fn loc tycon)
Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
Just gen_fn -> return (gen_fn loc tycon)
Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
,(showClassKey, gen_Show_binds fix_env)
,(readClassKey, gen_Read_binds fix_env)
,(dataClassKey, gen_Data_binds)
,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds)
]
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
,(showClassKey, gen_Show_binds fix_env)
,(readClassKey, gen_Read_binds fix_env)
,(dataClassKey, gen_Data_binds)
,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds)
]
\end{code}
%************************************************************************
......@@ -1568,10 +1527,6 @@ For the generic representation we need to generate:
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
@genGenericBinds@ does (1)
@genGenericRepExtras@ does (2) and (3)
@genGenericAll@ does all of them
\begin{code}
gen_Generic_binds :: TyCon -> Module
-> TcM (LHsBinds RdrName, BagDerivStuff)
......@@ -1582,10 +1537,7 @@ gen_Generic_binds tc mod = do
, (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
......@@ -1607,11 +1559,10 @@ genGenericRepExtras tc mod =
d_occ = mkGenD tc_occ
c_occ m = mkGenC tc_occ m
s_occ m n = mkGenS tc_occ m n
mod_name = mod
d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan
c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan
| (u,m) <- zip uniqsC [0..] ]
s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan
| (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
mkTyCon name = ASSERT( isExternalName name )
......
......@@ -68,23 +68,9 @@ 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 stuff
data DerivStuff -- Please add this auxiliary stuff
= DerivCon2Tag TyCon -- The con2Tag for given TyCon
| DerivTag2Con TyCon -- ...ditto tag2Con
| DerivMaxTag TyCon -- ...and maxTag
......@@ -95,15 +81,9 @@ data DerivStuff -- Please add these auxiliary stuff
| DerivTyCon TyCon -- New data types
| DerivFamInst TyCon -- New type family instances
| 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
-- New top-level auxiliary bindings
| DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
| DerivInst (InstInfo RdrName) -- New, auxiliary instances
isDupAux :: DerivStuff -> DerivStuff -> Bool
isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
......@@ -1283,9 +1263,8 @@ gen_Data_binds loc tycon
= (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?
listToBag ( DerivHsBind (genDataTyCon)
: map (DerivHsBind . genDataDataCon) data_cons))
where
data_cons = tyConDataCons tycon
n_cons = length data_cons
......@@ -1800,32 +1779,25 @@ genAuxBind loc (DerivMaxTag tycon)
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
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
-}
-- The other cases never happen (we filter them in genAuxBinds)
genAuxBind _ _ = panic "genAuxBind"
type SeparateBagsDerivStuff = ( Bag (LHsBind RdrName, LSig RdrName)
-- New bindings
, Bag TyCon -- New top-level datatypes
, Bag TyCon -- New family instances
, Bag (InstInfo RdrName)) -- New instances
genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
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 :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
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
f (DerivHsBind b) = add1 b
f (DerivTyCon t) = add2 t
f (DerivFamInst t) = add3 t
f (DerivInst i) = add4 i
add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment