[commit: ghc] wip/GenericsMetaData: Remove some left-over stuff (8b2a3d5)
git at git.haskell.org
git at git.haskell.org
Tue Nov 4 10:06:51 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/GenericsMetaData
Link : http://ghc.haskell.org/trac/ghc/changeset/8b2a3d51ca6c1adaa9c9da3d73fab83e3defe84d/ghc
>---------------------------------------------------------------
commit 8b2a3d51ca6c1adaa9c9da3d73fab83e3defe84d
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date: Tue Nov 4 10:01:54 2014 +0000
Remove some left-over stuff
>---------------------------------------------------------------
8b2a3d51ca6c1adaa9c9da3d73fab83e3defe84d
compiler/typecheck/TcDeriv.lhs | 25 ++++++-------------------
compiler/typecheck/TcGenDeriv.lhs | 18 +++++++-----------
compiler/typecheck/TcGenGenerics.lhs | 11 +++++------
3 files changed, 18 insertions(+), 36 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 2cf5131..25314b7 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -35,7 +35,6 @@ import RnNames( extendGlobalRdrEnvRn )
import RnBinds
import RnEnv
import RnSource ( addTcgDUs )
-import HscTypes
import Avail
import Unify( tcUnifyTy )
@@ -358,11 +357,6 @@ tcDeriving tycl_decls inst_decls deriv_decls
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
; traceTc "tcDeriving 1" (ppr early_specs)
- -- for each type, determine the auxliary declarations that are common
- -- to multiple derivations involving that type (e.g. Generic and
- -- Generic1 should use the same TcGenGenerics.MetaTyCons)
- -- ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
-
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; insts1 <- mapM genInst given_specs
@@ -375,7 +369,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
; loc <- getSrcSpanM
- ; let (binds, newTyCons, famInsts, extraInstances) =
+ ; let (binds, famInsts, extraInstances) =
genAuxBinds loc (unionManyBags deriv_stuff)
; (inst_info, rn_binds, rn_dus) <-
@@ -384,29 +378,22 @@ tcDeriving tycl_decls inst_decls deriv_decls
; dflags <- getDynFlags
; unless (isEmptyBag inst_info) $
liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
- (ddump_deriving inst_info rn_binds newTyCons famInsts))
+ (ddump_deriving inst_info rn_binds famInsts))
- ; let all_tycons = map ATyCon (bagToList newTyCons)
- ; gbl_env <- tcExtendGlobalEnv all_tycons $
- tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
- tcExtendLocalFamInstEnv (bagToList famInsts) $
+ ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
where
ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
- -> Bag TyCon -- ^ Empty data constructors
-> Bag FamInst -- ^ Rep type family instances
-> SDoc
- ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
+ ddump_deriving inst_infos extra_binds repFamInsts
= 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 (bagToList repMetaTys)))
- $$ hangP "Representation types:"
- (vcat (map pprRepTy (bagToList repFamInsts))))
+ $$ hangP "GHC.Generics representation types:"
+ (vcat (map pprRepTy (bagToList repFamInsts)))
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 31e31ed..fd83301 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -84,7 +84,6 @@ data DerivStuff -- Please add this auxiliary stuff
= DerivAuxBind AuxBindSpec
-- Generics
- | DerivTyCon TyCon -- New data types
| DerivFamInst FamInst -- New type family instances
-- New top-level auxiliary bindings
@@ -1992,7 +1991,6 @@ genAuxBindSpec loc (DerivMaxTag tycon)
type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
( Bag (LHsBind RdrName, LSig RdrName)
-- Extra bindings (used by Generic only)
- , Bag TyCon -- Extra top-level datatypes
, Bag (FamInst) -- Extra family instances
, Bag (InstInfo RdrName)) -- Extra instances
@@ -2007,18 +2005,16 @@ genAuxBinds loc b = genAuxBinds' b2 where
genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
- , emptyBag, emptyBag, emptyBag)
+ , emptyBag, emptyBag)
f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
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)
- add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
- add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
+ f (DerivFamInst t) = add2 t
+ f (DerivInst i) = add3 i
+
+ add1 x (a,b,c) = (x `consBag` a,b,c)
+ add2 x (a,b,c) = (a,x `consBag` b,c)
+ add3 x (a,b,c) = (a,b,x `consBag` c)
mk_data_type_name :: TyCon -> RdrName -- "$tT"
mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 2362a8d..582b1f3 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -514,11 +514,11 @@ tc_mkRepTy gk_ tycon =
(dataConFieldLabels a)]
-- This field has no label
-- mkS Nothing _ a = mkTyConApp s1 [mkTyConApp ms [mkTyConTy pNothing], a]
- mkS Nothing a = mkTyConApp s1 [{- typeKind msel, -} msel, a]
+ mkS Nothing a = mkTyConApp s1 [msel, a]
where msel = mkTyConApp ms [mkStrLitTy (mkFastString "")]
-- This field has a label
-- mkS (Just l) _ a = mkTyConApp s1 [mkTyConApp ms [mkTyConApp pJust [selName l]], a]
- mkS (Just l) a = mkTyConApp s1 [{- typeKind msel, -} msel, a]
+ mkS (Just l) a = mkTyConApp s1 [msel, a]
where msel = mkTyConApp ms [selName l]
-- Sums and products are done in the same way for both Rep and Rep1
@@ -581,7 +581,6 @@ tc_mkRepTy gk_ tycon =
metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
-- metaSelTy s = mkTyConApp mc [ctName c, ctFix c, isRec c]
- -- pprTrace "rep: " (ppr (metaDataTy, tycon, mkD tycon)) $
return (mkD tycon)
--------------------------------------------------------------------------------
@@ -676,10 +675,10 @@ genLR_E i n e
--------------------------------------------------------------------------------
-- Build a product expression
-mkProd_E :: GenericKind_DC -- Generic or Generic1?
- -> US -- Base for unique names
+mkProd_E :: GenericKind_DC -- Generic or Generic1?
+ -> US -- Base for unique names
-> [(RdrName, Type)] -- List of variables matched on the lhs and their types
- -> LHsExpr RdrName -- Resulting product expression
+ -> LHsExpr RdrName -- Resulting product expression
mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
-- These M1s are meta-information for the constructor
More information about the ghc-commits
mailing list