Merge branch 'fix#5464'

5 files changed, 373 insertions, 418 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 01bbeb067d..09b0fb9335 100644..100755
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -394,6 +394,7 @@ Library
         TcExpr
         TcForeign
         TcGenDeriv
+        TcGenGenerics
         TcHsSyn
         TcHsType
         TcInstDcls
@@ -418,7 +419,6 @@ Library
         Coercion
         FamInstEnv
         FunDeps
-        Generics
         InstEnv
         TyCon
         Kind
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index b3214f8d7f..d311647db3 100644..100755
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -13,20 +13,22 @@ module TcDeriv ( tcDeriving ) where
 import HsSyn
 import DynFlags
 
-import Generics
 import TcRnMonad
 import FamInst
 import TcEnv
 import TcClassDcl( tcAddDeclCtxt )	-- Small helper
 import TcGenDeriv			-- Deriv stuff
+import TcGenGenerics
 import InstEnv
 import Inst
+import FamInstEnv
 import TcHsType
 import TcMType
 import TcSimplify
 
 import RnBinds
 import RnEnv
+import RnSource   ( addTcgDUs )
 import HscTypes
 
 import Class
@@ -41,13 +43,10 @@ import Name
 import NameSet
 import TyCon
 import TcType
-import BuildTyCl
-import BasicTypes
 import Var
 import VarSet
 import PrelNames
 import SrcLoc
-import UniqSupply
 import Util
 import ListSetOps
 import Outputable
@@ -299,109 +298,97 @@ both of them.  So we gather defs/uses from deriving just like anything else.
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
-            -> TcM ([InstInfo Name] -- The generated "instance decls"
-                   ,HsValBinds Name -- Extra generated top-level bindings
-                   ,DefUses
-                   ,[TyCon]         -- Extra generated top-level types
-                   ,[TyCon])        -- Extra generated type family instances
-
+            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
+  = recoverM (do { g <- getGblEnv
+                 ; return (g, emptyBag, emptyValBindsOut)}) $
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
 	  is_boot <- tcIsHsBoot
 	; traceTc "tcDeriving" (ppr is_boot)
-	; (early_specs, genericsExtras) 
-                <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-        ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
+	; early_specs <- makeDerivSpecs is_boot 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
 
 	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
-			 inferInstanceContexts overlap_flag infer_specs
+                           inferInstanceContexts overlap_flag infer_specs
 
 	; insts2 <- mapM (genInst False overlap_flag) final_specs
 
-	-- We no longer generate the old generic to/from functions
-        -- from each type declaration, so this is emptyBag
-	; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
-	
-	; (inst_info, rn_binds, rn_dus)
-                <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
+        ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
+        ; loc <- getSrcSpanM
+        ; let (binds, newTyCons, famInsts, extraInstances) = 
+                genAuxBinds loc (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"
-	         (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
+	         (ddump_deriving inst_info rn_binds newTyCons famInsts extraInstances))
 {-
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
 -}
-	; return ( inst_info, rn_binds, rn_dus
-                 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
+
+  ; let all_tycons = map ATyCon (bagToList newTyCons)
+  ; gbl_env <- tcExtendGlobalEnv all_tycons $
+               tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+               tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
+               tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
+
+  ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
   where
-    ddump_deriving :: [InstInfo Name] -> HsValBinds Name 
-                   -> [MetaTyCons] -- ^ Empty data constructors
-                   -> [TyCon]      -- ^ Rep type family instances
-                   -> [[(InstInfo RdrName, DerivAuxBinds)]] 
+    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name 
+                   -> 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"))
-              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+      =    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
 
 
-renameDeriv :: Bool -> LHsBinds RdrName
-	    -> [(InstInfo RdrName, DerivAuxBinds)]
- 	    -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
-renameDeriv is_boot gen_binds insts
+renameDeriv :: Bool
+	    -> [InstInfo RdrName]
+	    -> Bag (LHsBind RdrName, LSig RdrName)
+ 	    -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
+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) <- mapAndUnzipM rn_inst_info inst_infos	
-	; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs 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	{ (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $  -- 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, aux_sigs) = unzip $ map (genAuxBind loc) $ 
-	                              rm_dups [] $ concat deriv_aux_binds
-              aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
+    do	{
+        -- 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
 	; bindLocalNames (collectHsValBinders rn_aux_lhs) $ 
     do	{ (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
 	; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
-	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
-                  dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
+	; return (listToBag rn_inst_infos, rn_aux,
+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 
   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 RdrName -> TcM (InstInfo Name, FreeVars)
     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
@@ -451,75 +438,20 @@ 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 
-                 -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
-mkGenDerivExtras tc = do
-        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
-        ; metaInsts                <- genDtMeta (tc, metaTyCons)
-        ; return (metaTyCons, rep0TyInst, metaInsts) }
-
 makeDerivSpecs :: Bool 
 	       -> [LTyClDecl Name] 
 	       -> [LInstDecl Name]
 	       -> [LDerivDecl Name] 
-	       -> TcM ( [EarlyDerivSpec]
-                      , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
+	       -> TcM [EarlyDerivSpec]
 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
   | is_boot     -- No 'deriving' at all in hs-boot files
   = do  { mapM_ add_deriv_err deriv_locs 
-        ; return ([],[]) }
+        ; return [] }
   | otherwise
   = do  { eqns1 <- mapAndRecoverM deriveTyData all_tydata
         ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
-
-        -- Generic representation stuff: we might need to add some "extras"
-        -- to the instances
-        ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
-        ; generic_extras_deriv <- if not xDerRep
-                                   -- No extras if the flag is off
-                                   then (return [])
-                                    else do {
-          let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
-        -- Select only those types that derive Generic
-        ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
-                                       , isGenClassName c ]
-        ; let sel_deriv_decls = catMaybes [ getTypeName t
-                                  | L _ (DerivDecl (L _ t)) <- deriv_decls ] 
-        ; derTyDecls <- mapM tcLookupTyCon $ 
-                         filter (needsExtras xDerRep
-                                  (sel_tydata ++ sel_deriv_decls)) allTyNames
-        -- We need to generate the extras to add to what has
-        -- already been derived
-        ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
-          pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
-          pprTrace "derTyDecls" (ppr derTyDecls) $
-          pprTrace "deriv_decls" (ppr deriv_decls) $ -}
-          mapM mkGenDerivExtras derTyDecls }
-
-        -- Merge and return
-        ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
+        ; return (eqns1 ++ eqns2) }
   where
-      -- We need extras if the flag DeriveGeneric is on and this type is 
-      -- deriving Generic
-    needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
-
-    -- Extracts the name of the class in the deriving and makes sure it is ours
-    isGenClassName :: HsType Name -> Bool
-    isGenClassName ty = case splitHsInstDeclTy_maybe ty of
-        Just (_, _, cls_name, _) -> cls_name == genClassName
-        _                        -> False
-
-    -- Extracts the name of the type in the deriving
-    -- This function (and also getClassName above) is not really nice, and I
-    -- might not have covered all possible cases. I wonder if there is no easier
-    -- way to extract class and type name from a LDerivDecl...
-    getTypeName :: HsType Name -> Maybe Name
-    getTypeName ty = do
-        (_, _, cls_name, [ty]) <- splitHsInstDeclTy_maybe ty
-        guard (cls_name == genClassName)
-        fmap fst $ splitHsClassTy_maybe (unLoc ty)
-
     extractTyDataPreds decls
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 
@@ -699,8 +631,9 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
       	   -- For standalone deriving (mtheta /= Nothing), 
       	   -- check that all the data constructors are in scope.
       	   ; rdr_env <- getGlobalRdrEnv
-      	   ; let hidden_data_cons = isAbstractTyCon rep_tc || 
-                                    any not_in_scope (tyConDataCons rep_tc)
+      	   ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
+                                    (isAbstractTyCon rep_tc || 
+                                     any not_in_scope (tyConDataCons rep_tc))
       	         not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
       	   ; unless (isNothing mtheta || not hidden_data_cons)
       	   	    (bale_out (derivingHiddenErr tycon))
@@ -1508,31 +1441,30 @@ the renamer.  What a great hack!
 --
 genInst :: Bool             -- True <=> standalone deriving
         -> OverlapFlag
-        -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
+        -> 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 (InstInfo { iSpec   = inst_spec
-                     , iBinds  = NewTypeDerived co rep_tycon }, [])
+                     , iBinds  = NewTypeDerived co rep_tycon }, emptyBag)
 
   | otherwise
-  = do  { fix_env <- getFixityEnv
-        ; let loc   = getSrcSpan name
-              (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
-                   -- In case of a family instance, we need to use the representation
-                   -- tycon (after all, it has the data constructors)
-
-        ; return (InstInfo { iSpec   = inst_spec
-                           , iBinds  = VanillaInst meth_binds [] standalone_deriv }
-                 , aux_binds) }
+  = do { fix_env <- getFixityEnv
+       ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) 
+                                        fix_env clas name rep_tycon
+       ; let inst_info = InstInfo { iSpec   = inst_spec
+                                  , iBinds  = VanillaInst meth_binds []
+                                                standalone_deriv }
+       ; return ( inst_info, deriv_stuff) }
   where
+
     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)
@@ -1545,174 +1477,35 @@ genInst standalone_deriv oflag
 --    co2 : R1:N (b,b) ~ Tree (b,b)
 --    co  : N [(b,b)] ~ Tree (b,b)
 
-genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
-genDerivBinds 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)
 
-  | otherwise
+  | classKey clas == genClassKey   -- Special case because monadic
+  = gen_Generic_binds tycon (nameModule name)
+
+  | otherwise	                   -- Non-monadic generators
   = case assocMaybe gen_list (getUnique clas) of
-	Just gen_fn -> gen_fn loc tycon
-	Nothing	    -> pprPanic "genDerivBinds: 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, DerivAuxBinds))]
+    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)
-	       ,(genClassKey,           genGenericBinds)
- 	       ]
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
-%*									*
-%************************************************************************
-
-For the generic representation we need to generate:
-\begin{itemize}
-\item A Generic instance
-\item A Rep type instance 
-\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}
-genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
-genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
-
-genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
-genGenericRepExtras tc =
-  do  uniqS <- newUniqueSupply
-      let
-        -- Uniques for everyone
-        (uniqD:uniqs) = uniqsFromSupply uniqS
-        (uniqsC,us) = splitAt (length tc_cons) uniqs
-        uniqsS :: [[Unique]] -- Unique supply for the S datatypes
-        uniqsS = mkUniqsS tc_arits us
-        mkUniqsS []    _  = []
-        mkUniqsS (n:t) us = case splitAt n us of
-                              (us1,us2) -> us1 : mkUniqsS t us2
-
-        tc_name   = tyConName tc
-        tc_cons   = tyConDataCons tc
-        tc_arits  = map dataConSourceArity tc_cons
-        
-        tc_occ    = nameOccName tc_name
-        d_occ     = mkGenD tc_occ
-        c_occ m   = mkGenC tc_occ m
-        s_occ m n = mkGenS tc_occ m n
-        mod_name  = nameModule (tyConName tc)
-        d_name    = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
-        c_names   = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
-                      | (u,m) <- zip uniqsC [0..] ]
-        s_names   = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan 
-                        | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
-        
-        mkTyCon name = ASSERT( isExternalName name )
-                       buildAlgTyCon name [] [] distinctAbstractTyConRhs
-                           NonRecursive False NoParentTyCon Nothing
-
-      metaDTyCon  <- mkTyCon d_name
-      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
-      metaSTyCons <- mapM sequence 
-                       [ [ mkTyCon s_name 
-                         | s_name <- s_namesC ] | s_namesC <- s_names ]
-
-      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
-  
-      rep0_tycon <- tc_mkRepTyCon tc metaDts
-      
-      -- pprTrace "rep0" (ppr rep0_tycon) $
-      return (metaDts, rep0_tycon)
-{-
-genGenericAll :: TyCon
-                  -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
-genGenericAll tc =
-  do  (metaDts, rep0_tycon)     <- genGenericRepExtras tc
-      clas                      <- tcLookupClass genClassName
-      dfun_name                 <- new_dfun_name clas tc
-      let
-        mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
-                               , [ {- No DerivAuxBinds -} ])
-        inst  = mkLocalInstance dfun NoOverlap
-        binds = VanillaInst (mkBindsRep tc) [] False
-
-        tvs   = tyConTyVars tc
-        tc_ty = mkTyConApp tc (mkTyVarTys tvs)
-        
-        dfun  = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
-      return (mkInstRep, metaDts, rep0_tycon)
--}
-genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
-genDtMeta (tc,metaDts) =
-  do  dflags <- getDOpts
-      dClas <- tcLookupClass datatypeClassName
-      d_dfun_name <- new_dfun_name dClas tc
-      cClas <- tcLookupClass constructorClassName
-      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
-      sClas <- tcLookupClass selectorClassName
-      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
-                                               | _ <- x ] 
-                                             | x <- metaS metaDts ])
-      fix_env <- getFixityEnv
-
-      let
-        safeOverlap = safeLanguageOn dflags
-        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
-        
-        -- Datatype
-        d_metaTycon = metaD metaDts
-        d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
-        d_binds = VanillaInst dBinds [] False
-        d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
-                    [ mkTyConTy d_metaTycon ]
-        d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
-        
-        -- Constructor
-        c_metaTycons = metaC metaDts
-        c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
-                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
-        c_binds = [ VanillaInst c [] False | c <- cBinds ]
-        c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
-                               [ mkTyConTy c ]
-        c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) 
-                   | (is,bs) <- myZip1 c_insts c_binds ]
-        
-        -- Selector
-        s_metaTycons = metaS metaDts
-        s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
-                                                  NoOverlap safeOverlap))
-                    (myZip2 s_metaTycons s_dfun_names)
-        s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
-        s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
-                               [ mkTyConTy s ]
-        s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
-                     (myZip2 s_insts s_binds)
-       
-        myZip1 :: [a] -> [b] -> [(a,b)]
-        myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
-        
-        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
-        myZip2 l1 l2 =
-          ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
-            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
-        
-      return (d_mkInst : c_mkInst ++ concat s_mkInst)
+               ,(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}
 
-
 %************************************************************************
 %*									*
 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index ad06d6e749..cf9c46a747 100644..100755
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation.
 
 \begin{code}
 module TcGenDeriv (
-	DerivAuxBinds, isDupAux,
+	BagDerivStuff, DerivStuff(..),
 
 	gen_Bounded_binds,
 	gen_Enum_binds,
@@ -28,7 +28,7 @@ module TcGenDeriv (
 	deepSubtypesContaining, foldDataConArgs,
 	gen_Foldable_binds,
 	gen_Traversable_binds,
-	genAuxBind,
+	genAuxBinds,
         ordOpTbl, boxConTbl
     ) where
 
@@ -62,32 +62,32 @@ import FastString
 import Bag
 import Fingerprint
 import Constants
+import TcEnv (InstInfo)
 
 import Data.List        ( partition, intersperse )
 \end{code}
 
 \begin{code}
-type DerivAuxBinds = [DerivAuxBind]
-
-data DerivAuxBind		-- Please add these auxiliary top-level bindings
-  = GenCon2Tag TyCon		-- The con2Tag for given TyCon
-  | GenTag2Con TyCon		-- ...ditto tag2Con
-  | GenMaxTag  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
-
-
-isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
-isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
-isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
-isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
-isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
-isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
-isDupAux _                _                = False
+type BagDerivStuff = Bag DerivStuff
+
+data AuxBindSpec
+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
+  | DerivTag2Con TyCon  -- ...ditto tag2Con
+  | DerivMaxTag  TyCon  -- ...and maxTag
+  deriving( Eq )
+  -- All these generate ZERO-BASED tag operations
+  -- I.e first constructor has tag 0
+
+data DerivStuff     -- Please add this auxiliary stuff
+  = DerivAuxBind AuxBindSpec
+
+  -- Generics
+  | DerivTyCon TyCon      -- New data types
+  | DerivFamInst TyCon    -- New type family instances
+
+  -- New top-level auxiliary bindings 
+  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
+  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
 \end{code}
 
 
@@ -166,7 +166,7 @@ instance ... Eq (Foo ...) where
 
 
 \begin{code}
-gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Eq_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -186,8 +186,8 @@ gen_Eq_binds loc tycon
     	    untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
     	               (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
-    aux_binds | no_nullary_cons = []
-	      | otherwise       = [GenCon2Tag tycon]
+    aux_binds | no_nullary_cons = emptyBag
+	      | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
     method_binds = listToBag [eq_bind, ne_bind]
     eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
@@ -324,15 +324,15 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+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 $ mk_FunBind loc compare_RDR [], [])
+  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
   | otherwise
   = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
   where
-    aux_binds | single_con_type = []
-              | otherwise       = [GenCon2Tag tycon]
+    aux_binds | single_con_type = emptyBag
+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
 	-- Note [Do not rely on compare]
     other_ops | (last_tag - first_tag) <= 2 	-- 1-3 constructors
@@ -547,7 +547,7 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 
 \begin{code}
-gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Enum_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -559,7 +559,8 @@ gen_Enum_binds loc tycon
 			enum_from_then,
 			from_enum
 		    ]
-    aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
+    aux_binds = listToBag $ map DerivAuxBind
+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
 
@@ -626,13 +627,13 @@ gen_Enum_binds loc tycon
 %************************************************************************
 
 \begin{code}
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
-  = (listToBag [ min_bound_enum, max_bound_enum ], [])
+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
   | otherwise
   = ASSERT(isSingleton data_cons)
-    (listToBag [ min_bound_1con, max_bound_1con ], [])
+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
   where
     data_cons = tyConDataCons tycon
 
@@ -713,13 +714,15 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 
 \begin{code}
-gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Ix_binds loc tycon
   | isEnumerationTyCon tycon
-  = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
+  = ( enum_ixes
+    , listToBag $ map DerivAuxBind
+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
   | otherwise
-  = (single_con_ixes, [GenCon2Tag tycon])
+  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
   where
     --------------------------------------------------------------
     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
@@ -872,10 +875,10 @@ instance Read T where
 
 
 \begin{code}
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Read_binds get_fixity loc tycon
-  = (listToBag [read_prec, default_readlist, default_readlistprec], [])
+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
   where
     -----------------------------------------------------------------------
     default_readlist 
@@ -1041,10 +1044,10 @@ Example
 		    -- the most tightly-binding operator
 
 \begin{code}
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Show_binds get_fixity loc tycon
-  = (listToBag [shows_prec, show_list], [])
+  = (listToBag [shows_prec, show_list], emptyBag)
   where
     -----------------------------------------------------------------------
     show_list = mkHsVarBind loc showList_RDR
@@ -1254,17 +1257,53 @@ we generate
 gen_Data_binds :: SrcSpan
 	       -> TyCon 
 	       -> (LHsBinds RdrName,	-- The method bindings
-		   DerivAuxBinds)	-- Auxiliary bindings
+		   BagDerivStuff)	-- Auxiliary bindings
 gen_Data_binds loc tycon
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
      `unionBags` gcast_binds,
 		-- Auxiliary definitions: the data type and constructors
-     MkTyCon tycon : map MkDataCon data_cons)
+     listToBag ( DerivHsBind (genDataTyCon)
+               : map (DerivHsBind . genDataDataCon) data_cons))
   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)
           
@@ -1416,9 +1455,9 @@ 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 -> (LHsBinds RdrName, DerivAuxBinds)
+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 = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
@@ -1587,9 +1626,9 @@ 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 -> (LHsBinds RdrName, DerivAuxBinds)
+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
 
@@ -1639,9 +1678,9 @@ 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 -> (LHsBinds RdrName, DerivAuxBinds)
+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
 
@@ -1694,8 +1733,8 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
 
 \begin{code}
-genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
-genAuxBind loc (GenCon2Tag tycon)
+genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
+genAuxBindSpec loc (DerivCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns, 
      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
   where
@@ -1718,7 +1757,7 @@ genAuxBind loc (GenCon2Tag tycon)
     mk_eqn con = ([nlWildConPat con], 
 		  nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
 
-genAuxBind loc (GenTag2Con tycon)
+genAuxBindSpec loc (DerivTag2Con tycon)
   = (mk_FunBind loc rdr_name 
 	[([nlConVarPat intDataCon_RDR [a_RDR]], 
 	   nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
@@ -1729,7 +1768,7 @@ genAuxBind loc (GenTag2Con tycon)
 
     rdr_name = tag2con_RDR tycon
 
-genAuxBind loc (GenMaxTag tycon)
+genAuxBindSpec loc (DerivMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
   where
@@ -1739,38 +1778,36 @@ genAuxBind loc (GenMaxTag tycon)
     max_tag =  case (tyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
-genAuxBind loc (MkTyCon 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 (MkDataCon 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
+type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
+                              ( Bag (LHsBind RdrName, LSig RdrName)
+                                -- Extra bindings (used by Generic only)
+                              , Bag TyCon -- Extra top-level datatypes
+                              , Bag TyCon -- Extra family instances
+                              , Bag (InstInfo RdrName)) -- Extra instances
+
+genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
+genAuxBinds loc b = genAuxBinds' b2 where
+  (b1,b2) = partitionBagWith splitDerivAuxBind b
+  splitDerivAuxBind (DerivAuxBind x) = Left x
+  splitDerivAuxBind  x               = Right x
+
+  rm_dups = foldrBag dup_check emptyBag
+  dup_check a b = if anyBag (== a) b then b else consBag a b
+  
+  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
+                            , 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)
 
 mk_data_type_name :: TyCon -> RdrName 	-- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
diff --git a/compiler/types/Generics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 323da41d66..543204759c 100644..100755
--- a/compiler/types/Generics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -2,45 +2,175 @@
 % (c) The University of Glasgow 2011
 %
 
+The deriving code for the Generic class
+(equivalent to the code in TcGenDeriv, for other classes)
+
 \begin{code}
 
-module Generics ( canDoGenerics,
-		  mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
-		  MetaTyCons(..), metaTyCons2TyCons
-    ) where
+module TcGenGenerics (canDoGenerics, gen_Generic_binds) where
 
 
+import DynFlags
 import HsSyn
 import Type
 import TcType
+import TcGenDeriv
 import DataCon
-
 import TyCon
 import Name hiding (varName)
-import Module (moduleName, moduleNameString)
+import Module (Module, moduleName, moduleNameString)
+import IfaceEnv (newGlobalBinder)
 import RdrName
 import BasicTypes
 import TysWiredIn
 import PrelNames
-
--- For generation of representation types
-import TcEnv (tcLookupTyCon)
+import InstEnv
+import TcEnv
+import MkId
 import TcRnMonad
 import HscTypes
 import BuildTyCl
-
 import SrcLoc
 import Bag
 import Outputable 
 import FastString
+import UniqSupply
 
 #include "HsVersions.h"
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
+\subsection{Bindings for the new generic deriving mechanism}
+%*                                                                      *
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance 
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+\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)) }
+
+genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc mod =
+  do  uniqS <- newUniqueSupply
+      let
+        -- Uniques for everyone
+        (uniqD:uniqs) = uniqsFromSupply uniqS
+        (uniqsC,us) = splitAt (length tc_cons) uniqs
+        uniqsS :: [[Unique]] -- Unique supply for the S datatypes
+        uniqsS = mkUniqsS tc_arits us
+        mkUniqsS []    _  = []
+        mkUniqsS (n:t) us = case splitAt n us of
+                              (us1,us2) -> us1 : mkUniqsS t us2
+
+        tc_name   = tyConName tc
+        tc_cons   = tyConDataCons tc
+        tc_arits  = map dataConSourceArity tc_cons
+        
+        tc_occ    = nameOccName tc_name
+        d_occ     = mkGenD tc_occ
+        c_occ m   = mkGenC tc_occ m
+        s_occ m n = mkGenS tc_occ m n
+        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 (s_occ m n) wiredInSrcSpan 
+                        | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
+        
+        mkTyCon name = ASSERT( isExternalName name )
+                       buildAlgTyCon name [] [] distinctAbstractTyConRhs
+                           NonRecursive False NoParentTyCon Nothing
+
+      metaDTyCon  <- mkTyCon d_name
+      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
+      metaSTyCons <- mapM sequence 
+                       [ [ mkTyCon s_name 
+                         | s_name <- s_namesC ] | s_namesC <- s_names ]
+
+      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
+  
+      rep0_tycon <- tc_mkRepTyCon tc metaDts mod
+      
+      -- pprTrace "rep0" (ppr rep0_tycon) $
+      return (metaDts, rep0_tycon)
+
+genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff
+genDtMeta (tc,metaDts) =
+  do  loc <- getSrcSpanM
+      dflags <- getDOpts
+      dClas <- tcLookupClass datatypeClassName
+      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
+      d_dfun_name <- new_dfun_name dClas tc
+      cClas <- tcLookupClass constructorClassName
+      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
+      sClas <- tcLookupClass selectorClassName
+      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
+                                               | _ <- x ] 
+                                             | x <- metaS metaDts ])
+      fix_env <- getFixityEnv
+
+      let
+        safeOverlap = safeLanguageOn dflags
+        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+        
+        -- Datatype
+        d_metaTycon = metaD metaDts
+        d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
+        d_binds = VanillaInst dBinds [] False
+        d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
+                    [ mkTyConTy d_metaTycon ]
+        d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
+        
+        -- Constructor
+        c_metaTycons = metaC metaDts
+        c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
+                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
+        c_binds = [ VanillaInst c [] False | c <- cBinds ]
+        c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
+                               [ mkTyConTy c ]
+        c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
+                   | (is,bs) <- myZip1 c_insts c_binds ]
+        
+        -- Selector
+        s_metaTycons = metaS metaDts
+        s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
+                                                  NoOverlap safeOverlap))
+                    (myZip2 s_metaTycons s_dfun_names)
+        s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
+        s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
+                               [ mkTyConTy s ]
+        s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
+                                                             , iBinds = bs})))
+                       (myZip2 s_insts s_binds)
+       
+        myZip1 :: [a] -> [b] -> [(a,b)]
+        myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
+        
+        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
+        myZip2 l1 l2 =
+          ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
+            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
+        
+      return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst))
+\end{code}
+
+%************************************************************************
+%*                                                                      *
 \subsection{Generating representation types}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -73,9 +203,7 @@ canDoGenerics tycon
                           then (Just (ppr dc <+> text "must be a vanilla data constructor"))
                           else Nothing)
 
-
 	-- Nor can we do the job if it's an existential data constructor,
-
 	-- Nor if the args are polymorphic types (I don't think)
     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
     
@@ -119,10 +247,11 @@ mkBindsRep tycon =
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepTyCon :: TyCon           -- The type to generate representation for
+tc_mkRepTyCon :: TyCon            -- The type to generate representation for
                -> MetaTyCons      -- Metadata datatypes to refer to
+               -> Module          -- Used as the location of the new RepTy
                -> TcM TyCon       -- Generated representation0 type
-tc_mkRepTyCon tycon metaDts = 
+tc_mkRepTyCon tycon metaDts mod = 
 -- Consider the example input tycon `D`, where data D a b = D_ a
   do { -- `rep0` = GHC.Generics.Rep (type family)
        rep0 <- tcLookupTyCon repTyConName
@@ -131,7 +260,9 @@ tc_mkRepTyCon tycon metaDts =
      ; rep0Ty <- tc_mkRepTy tycon metaDts
     
        -- `rep_name` is a name we generate for the synonym
-     ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+--     ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+     ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
+                     (nameSrcSpan (tyConName tycon))
      ; let -- `tyvars` = [a,b]
            tyvars  = tyConTyVars tycon
 
@@ -144,6 +275,8 @@ tc_mkRepTyCon tycon metaDts =
      ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
                      NoParentTyCon (Just (rep0, appT)) }
 
+
+
 --------------------------------------------------------------------------------
 -- Type representation
 --------------------------------------------------------------------------------
@@ -220,8 +353,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
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 970ce0d8c1..0061e5f6e5 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -25,7 +25,6 @@ import FamInst
 import FamInstEnv
 import TcDeriv
 import TcEnv
-import RnSource   ( addTcgDUs )
 import TcHsType
 import TcUnify
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
@@ -399,29 +398,22 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
          failIfErrsM    -- If the addInsts stuff gave any errors, don't
                         -- try the deriving stuff, because that may give
                         -- more errors still
-       ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
-              <- tcDeriving tycl_decls inst_decls deriv_decls
 
-       -- Extend the global environment also with the generated datatypes for
-       -- the generic representation
-       ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
-       ; gbl_env <- tcExtendGlobalEnv all_tycons $
-                    tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
-                    addFamInsts deriv_ty_insts $
-                    addInsts deriv_inst_info getGblEnv
+       ; (gbl_env, deriv_inst_info, deriv_binds)
+              <- tcDeriving tycl_decls inst_decls deriv_decls
 
        -- Check that if the module is compiled with -XSafe, there are no
        -- hand written instances of Typeable as then unsafe casts could be
-       -- performed. Derivied instances are OK.
+       -- performed. Derived instances are OK.
        ; dflags <- getDOpts
        ; when (safeLanguageOn dflags) $
              mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
                    local_info
 
-       ; return ( addTcgDUs gbl_env deriv_dus,
-                  deriv_inst_info ++ local_info,
-                  aux_binds `plusHsValBinds` deriv_binds)
+       ; return ( gbl_env
+                , (bagToList deriv_inst_info) ++ local_info
+                , aux_binds `plusHsValBinds` deriv_binds)
     }}}
   where
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"