Skip to content

Commit

Permalink
Some more refactoring.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dreixel
dreixel committed Oct 5, 2011
1 parent 3f50b5b commit 4830c8c
Show file tree
Hide file tree
Showing 2 changed files with 59 additions and 136 deletions.
125 changes: 38 additions & 87 deletions compiler/typecheck/TcDeriv.lhs
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -315,7 +315,6 @@ tcDeriving tycl_decls inst_decls deriv_decls
; overlap_flag <- getOverlapFlag ; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs ; let (infer_specs, given_specs) = splitEithers early_specs
; insts1 <- mapM (genInst True overlap_flag) given_specs ; insts1 <- mapM (genInst True overlap_flag) given_specs
-- ; let (insts,_) = partitionBagWith unDerivInst deriv1
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
inferInstanceContexts overlap_flag infer_specs inferInstanceContexts overlap_flag infer_specs
Expand All @@ -331,21 +330,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
; dflags <- getDOpts ; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" ; 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)) $ ; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds) 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) ; let all_tycons = map ATyCon (bagToList newTyCons)
; gbl_env <- tcExtendGlobalEnv all_tycons $ ; gbl_env <- tcExtendGlobalEnv all_tycons $
tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
Expand All @@ -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 dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
-> [MetaTyCons] -- ^ Empty data constructors -> Bag TyCon -- ^ Empty data constructors
-> [TyCon] -- ^ Rep type family instances -> Bag TyCon -- ^ Rep type family instances
-> [[(InstInfo RdrName, BagDerivStuff)]] -> Bag (InstInfo RdrName)
-- ^ Instances for the repMetaTys -- ^ Instances for the repMetaTys
-> SDoc -> SDoc
ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts 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)) 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
$$ ppr extra_binds) $$ ppr extra_binds)
$$ hangP "Generic representation" ( $$ hangP "Generic representation:" (
hangP "Generated datatypes for meta-information" hangP "Generated datatypes for meta-information:"
(vcat (map ppr repMetaTys)) (vcat (map ppr (bagToList repMetaTys)))
-- The Outputable instance for TyCon unfortunately only prints the name... -- The Outputable instance for TyCon unfortunately only prints the name...
$$ hangP "Representation types" $$ hangP "Representation types:"
(vcat (map ppr repTyCons)) (vcat (map ppr (bagToList repTyCons)))
$$ hangP "Meta-information instances" $$ hangP "Meta-information instances:"
(vcat (map (pprInstInfoDetails . fst) (concat metaInsts)))) (vcat (map pprInstInfoDetails (bagToList metaInsts))))
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
Expand All @@ -395,10 +385,8 @@ renameDeriv is_boot inst_infos bagBinds
| otherwise | otherwise
= discardWarnings $ -- Discard warnings about unused bindings etc = discardWarnings $ -- Discard warnings about unused bindings etc
do { do {
-- Generate and rename any extra not-one-inst-decl-specific binds, -- Bring the extra deriving stuff into scope
-- notably "con2tag" and/or "tag2con" functions. -- before renaming the instances themselves
-- Bring those names into scope before renaming the instances themselves
-- loc <- getSrcSpanM -- Generic loc for shared bindings
; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
Expand All @@ -409,10 +397,6 @@ renameDeriv is_boot inst_infos bagBinds
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
where 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 :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc }) rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
Expand All @@ -431,11 +415,6 @@ renameDeriv is_boot inst_infos bagBinds
where where
(tyvars,_, clas,_) = instanceHead inst (tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas clas_nm = className clas
{-
unDerivInst :: DerivStuff -> Either (InstInfo RdrName) DerivStuff
unDerivInst (DerivInst x) = Left x
unDerivInst x = Right x
-}
\end{code} \end{code}


Note [Newtype deriving and unused constructors] Note [Newtype deriving and unused constructors]
Expand Down Expand Up @@ -1483,37 +1462,17 @@ genInst standalone_deriv oflag
= do { fix_env <- getFixityEnv = do { fix_env <- getFixityEnv
; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
fix_env clas name rep_tycon fix_env clas name rep_tycon
; let { ; let inst_info = InstInfo { iSpec = inst_spec
{- , iBinds = VanillaInst meth_binds []
; (meth_binds', aux_binds) = partitionBag isDerivHsBind deriv_stuff standalone_deriv }
; 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
-}
; return ( inst_info, deriv_stuff) } ; return ( inst_info, deriv_stuff) }
where where
{-
isDerivHsBind (DerivHsBind _) = True
isDerivHsBind _ = False
unDerivHsBind (DerivHsBind x) = x
unDerivHsBind _ = panic "unDerivHsBind"
-}
inst_spec = mkInstance oflag theta spec inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkAxInstCo co_con rep_tc_args Just co_con -> mkAxInstCo co_con rep_tc_args
Nothing -> id_co Nothing -> id_co
-- Not a family => rep_tycon = main tycon -- Not a family => rep_tycon = main tycon
co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
co = co1 `mkTransCo` co2 co = co1 `mkTransCo` co2
id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
Expand All @@ -1537,22 +1496,22 @@ genDerivStuff loc fix_env clas name tycon
| otherwise | otherwise
= case assocMaybe gen_list (getUnique clas) of = case assocMaybe gen_list (getUnique clas) of
Just gen_fn -> return (gen_fn loc tycon) Just gen_fn -> return (gen_fn loc tycon)
Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
where where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [(eqClassKey, gen_Eq_binds) gen_list = [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds) ,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds) ,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds) ,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds) ,(ixClassKey, gen_Ix_binds)
,(showClassKey, gen_Show_binds fix_env) ,(showClassKey, gen_Show_binds fix_env)
,(readClassKey, gen_Read_binds fix_env) ,(readClassKey, gen_Read_binds fix_env)
,(dataClassKey, gen_Data_binds) ,(dataClassKey, gen_Data_binds)
,(functorClassKey, gen_Functor_binds) ,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds) ,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds) ,(traversableClassKey, gen_Traversable_binds)
] ]
\end{code} \end{code}


%************************************************************************ %************************************************************************
Expand All @@ -1568,10 +1527,6 @@ For the generic representation we need to generate:
\item Many auxiliary datatypes and instances for them (for the meta-information) \item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize} \end{itemize}


@genGenericBinds@ does (1)
@genGenericRepExtras@ does (2) and (3)
@genGenericAll@ does all of them

\begin{code} \begin{code}
gen_Generic_binds :: TyCon -> Module gen_Generic_binds :: TyCon -> Module
-> TcM (LHsBinds RdrName, BagDerivStuff) -> TcM (LHsBinds RdrName, BagDerivStuff)
Expand All @@ -1582,10 +1537,7 @@ gen_Generic_binds tc mod = do
, (DerivFamInst rep0TyInst) , (DerivFamInst rep0TyInst)
`consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
`unionBags` metaInsts)) } `unionBags` metaInsts)) }
{-
genGenericBinds :: SrcSpan -> TyCon -> BagDerivStuff
genGenericBinds _ tc = mapBag DerivHsBind $ mkBindsRep tc
-}
genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon) genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
genGenericRepExtras tc mod = genGenericRepExtras tc mod =
do uniqS <- newUniqueSupply do uniqS <- newUniqueSupply
Expand All @@ -1607,11 +1559,10 @@ genGenericRepExtras tc mod =
d_occ = mkGenD tc_occ d_occ = mkGenD tc_occ
c_occ m = mkGenC tc_occ m c_occ m = mkGenC tc_occ m
s_occ m n = mkGenS tc_occ m n s_occ m n = mkGenS tc_occ m n
mod_name = mod d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan
d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan
c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
| (u,m) <- zip uniqsC [0..] ] | (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..] ] | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
mkTyCon name = ASSERT( isExternalName name ) mkTyCon name = ASSERT( isExternalName name )
Expand Down
70 changes: 21 additions & 49 deletions compiler/typecheck/TcGenDeriv.lhs
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -68,23 +68,9 @@ import Data.List ( partition, intersperse )
\end{code} \end{code}


\begin{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 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 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
| DerivTag2Con TyCon -- ...ditto tag2Con | DerivTag2Con TyCon -- ...ditto tag2Con
| DerivMaxTag TyCon -- ...and maxTag | DerivMaxTag TyCon -- ...and maxTag
Expand All @@ -95,15 +81,9 @@ data DerivStuff -- Please add these auxiliary stuff
| DerivTyCon TyCon -- New data types | DerivTyCon TyCon -- New data types
| DerivFamInst TyCon -- New type family instances | DerivFamInst TyCon -- New type family instances
| DerivHsBind (LHsBind RdrName) -- New top-level auxiliary bindings -- New top-level auxiliary bindings
| DerivInst (InstInfo RdrName) -- New, auxiliary instances | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
| 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 :: DerivStuff -> DerivStuff -> Bool
isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2 isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
Expand Down Expand Up @@ -1283,9 +1263,8 @@ gen_Data_binds loc tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds, `unionBags` gcast_binds,
-- Auxiliary definitions: the data type and constructors -- Auxiliary definitions: the data type and constructors
listToBag ( DerivHsBind (fst genDataTyCon) listToBag ( DerivHsBind (genDataTyCon)
: map (DerivHsBind . fst . genDataDataCon) data_cons)) : map (DerivHsBind . genDataDataCon) data_cons))
-- JPM: We are dropping the signatures. Is this a problem?
where where
data_cons = tyConDataCons tycon data_cons = tyConDataCons tycon
n_cons = length data_cons n_cons = length data_cons
Expand Down Expand Up @@ -1800,32 +1779,25 @@ genAuxBind loc (DerivMaxTag tycon)
max_tag = case (tyConDataCons tycon) of max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG) data_cons -> toInteger ((length data_cons) - fIRST_TAG)
genAuxBind loc _ = panic "genAuxBind" -- The other cases never happen (we filter them in genAuxBinds)
genAuxBind _ _ = panic "genAuxBind"
genAuxBinds :: SrcSpan -> BagDerivStuff
-> ( Bag (LHsBind RdrName, LSig RdrName) type SeparateBagsDerivStuff = ( Bag (LHsBind RdrName, LSig RdrName)
, Bag TyCon -- New bindings
, Bag TyCon , Bag TyCon -- New top-level datatypes
, Bag (InstInfo RdrName)) , Bag TyCon -- New family instances
{- , Bag (InstInfo RdrName)) -- New instances
genAuxBinds loc = mapBag (genAuxBind loc) . filterBag (not . isGen)
isGen (DerivCon2Tag _) = True genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
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 genAuxBinds loc s = foldrBag f (emptyBag, emptyBag, emptyBag, emptyBag) s where
f :: DerivStuff f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
-> (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@(DerivCon2Tag _) = add1 (genAuxBind loc x)
f x@(DerivTag2Con _) = add1 (genAuxBind loc x) f x@(DerivTag2Con _) = add1 (genAuxBind loc x)
f x@(DerivMaxTag _) = add1 (genAuxBind loc x) f x@(DerivMaxTag _) = add1 (genAuxBind loc x)
f (DerivTyCon t) = add2 t f (DerivHsBind b) = add1 b
f (DerivFamInst t) = add3 t f (DerivTyCon t) = add2 t
f (DerivInst i) = add4 i f (DerivFamInst t) = add3 t
f _ = id f (DerivInst i) = add4 i
add1 x (a,b,c,d) = (x `consBag` a,b,c,d) add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
add2 x (a,b,c,d) = (a,x `consBag` b,c,d) add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
Expand Down

0 comments on commit 4830c8c

Please sign in to comment.