Allow deriving Generic1

This completes the support for generic programming introduced
in GHC 7.2. Generic1 allows defining generic functions that
operate on type containers, such as `fmap`, for instance.

Along the way we have fixed #5936 and #5939, allowing
deriving Generic/Generic1 for data families, and disallowing
deriving Generic/Generic1 for instantiated types.

Most of this patch is Nicolas Frisby's work.

4 files changed, 521 insertions, 169 deletions

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 27e995a839..553797f263 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -63,7 +63,7 @@ module OccName (
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
   	mkClassDataConOcc, mkDictOcc, mkIPOcc, 
  	mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- 	mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
+ 	mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 	mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc,
@@ -575,7 +575,7 @@ isDerivedOccName occ =
 mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
   	mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
  	mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- 	mkGenD, mkGenR, mkGenRCo,
+ 	mkGenD, mkGenR, mkGen1R, mkGenRCo,
 	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
@@ -618,6 +618,7 @@ mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
                    (occNameString occ)
 
 mkGenR   = mk_simple_deriv tcName "Rep_"
+mkGen1R  = mk_simple_deriv tcName "Rep1_"
 mkGenRCo = mk_simple_deriv tcName "CoRep_"
 
 -- data T = MkT ... deriving( Data ) needs defintions for 
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 3a39d531bb..31749744e7 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -355,7 +355,6 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
-gHC_GENERICS    = mkPrimModule (fsLit "GHC.Generics")
 gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")
 gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")
 gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes")
@@ -404,6 +403,7 @@ gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
 rANDOM          = mkBaseModule (fsLit "System.Random")
 gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
+gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")
 gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")
 gHC_IP          = mkBaseModule (fsLit "GHC.IP")
 
@@ -627,8 +627,10 @@ error_RDR = varQual_RDR gHC_ERR (fsLit "error")
 -- Generics (constructors and functions)
 u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
   k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
-  prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR,
-  to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
+  prodDataCon_RDR, comp1DataCon_RDR,
+  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,
+  from_RDR, from1_RDR, to_RDR, to1_RDR,
+  datatypeName_RDR, moduleName_RDR, conName_RDR,
   conFixity_RDR, conIsRecord_RDR,
   noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
   prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
@@ -646,6 +648,11 @@ r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")
 prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")
 comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
 
+unPar1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unPar1")
+unRec1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unRec1")
+unK1_RDR    = varQual_RDR gHC_GENERICS (fsLit "unK1")
+unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1")
+
 from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from")
 from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
 to_RDR    = varQual_RDR gHC_GENERICS (fsLit "to")
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1dc2d26385..bbda3cfcf0 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -316,25 +316,34 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	; traceTc "tcDeriving" (ppr is_boot)
 	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
+        -- 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 (either id id) early_specs
+
 	; overlap_flag <- getOverlapFlag
 	; let (infer_specs, given_specs) = splitEithers early_specs
-	; insts1 <- mapM (genInst True overlap_flag) given_specs
+	; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
 
+        -- the stand-alone derived instances (@insts1@) are used when inferring
+        -- the contexts for "deriving" clauses' instances (@infer_specs@)
 	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
                            inferInstanceContexts overlap_flag infer_specs
 
-	; insts2 <- mapM (genInst False overlap_flag) final_specs
+	; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
 
         ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
         ; loc <- getSrcSpanM
         ; let (binds, newTyCons, famInsts, extraInstances) = 
-                genAuxBinds loc (unionManyBags deriv_stuff)
+                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
+
         ; (inst_info, rn_binds, rn_dus) <-
             renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
 
-	; dflags <- getDynFlags
-	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-	         (ddump_deriving inst_info rn_binds newTyCons famInsts))
+        ; dflags <- getDynFlags
+        ; unless (isEmptyBag inst_info) $
+            liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                   (ddump_deriving inst_info rn_binds newTyCons famInsts))
 
         ; let all_tycons = map ATyCon (bagToList newTyCons)
         ; gbl_env <- tcExtendGlobalEnv all_tycons $
@@ -360,6 +369,25 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
+
+
+-- As of 24 April 2012, this only shares MetaTyCons between derivations of
+-- Generic and Generic1; thus the types and logic are quite simple.
+type CommonAuxiliary = MetaTyCons
+type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
+commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff)
+commonAuxiliaries = foldM snoc ([], emptyBag) where
+  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
+    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
+      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
+    | otherwise = return acc
+   where extendComAux m -- don't run m if its already in the accumulator
+           | any ((rep_tycon ==) . fst) cas = return acc
+           | otherwise = do (ca, new_stuff) <- m
+                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
+
+
+
 -- Prints the representable type family instance
 pprRepTy :: FamInst -> SDoc
 pprRepTy fi
@@ -632,7 +660,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
      mk_alg_eqn tycon tc_args
       | className cls `elem` typeableClassNames
       = do { dflags <- getDynFlags
-           ; case checkTypeableConditions (dflags, tycon) of
+           ; case checkTypeableConditions (dflags, tycon, tc_args) of
                Just err -> bale_out err
                Nothing  -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
 
@@ -687,7 +715,7 @@ mkDataTypeEqn :: CtOrigin
 
 mkDataTypeEqn orig dflags tvs cls cls_tys
               tycon tc_args rep_tc rep_tc_args mtheta
-  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
+  = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
 	-- NB: pass the *representation* tycon to checkSideConditions
 	CanDerive               -> go_for_it
 	NonDerivableClass	-> bale_out (nonStdErr cls)
@@ -702,8 +730,11 @@ mk_data_eqn :: CtOrigin -> [TyVar] -> Class
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
   = do	{ dfun_name <- new_dfun_name cls tycon
   	; loc <- getSrcSpanM
+        -- TODO NSF 9 April 2012: only recover from the anticipated
+        -- "base:Data.Functor.Functor could not be found" error
+        ; (_, functorClass_maybe) <- tryTc $ tcLookupClass functorClassName
 	; let inst_tys = [mkTyConApp tycon tc_args]
-	      inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
+	      inferred_constraints = inferConstraints functorClass_maybe tvs cls inst_tys rep_tc rep_tc_args
 	      spec = DS { ds_loc = loc, ds_orig = orig
 			, ds_name = dfun_name, ds_tvs = tvs
 			, ds_cls = cls, ds_tys = inst_tys
@@ -747,23 +778,29 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
 		     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
 
 ----------------------
-inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
+inferConstraints :: Maybe Class -> -- the base:Functor class, if in scope
+                    [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
 -- Generate a sufficiently large set of constraints that typechecking the
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
-inferConstraints _ cls inst_tys rep_tc rep_tc_args
+inferConstraints functorClass_maybe _ cls inst_tys rep_tc rep_tc_args
   -- Generic constraints are easy
   | cls `hasKey` genClassKey
   = []
+  | cls `hasKey` gen1ClassKey
+  = ASSERT (length rep_tc_tvs > 0)
+    con_arg_constraints functorClass_maybe (get_gen1_constrained_tys last_tv) 
   -- The others are a bit more complicated
   | otherwise
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
     stupid_constraints ++ extra_constraints
-    ++ sc_constraints ++ con_arg_constraints
+    ++ sc_constraints
+    ++ con_arg_constraints (Just cls) get_std_constrained_tys
   where
        -- Constraints arising from the arguments of each constructor
-    con_arg_constraints
-      = [ mkClassPred cls [arg_ty]
+    con_arg_constraints Nothing _ = []
+    con_arg_constraints (Just cls') get_constrained_tys
+      = [ mkClassPred cls' [arg_ty]
         | data_con <- tyConDataCons rep_tc,
           arg_ty   <- ASSERT( isVanillaDataCon data_con )
     			get_constrained_tys $
@@ -778,14 +815,15 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
     		-- (b) The rep_tc_args will be one short
     is_functor_like = getUnique cls `elem` functorLikeClassKeys
 
-    get_constrained_tys :: [Type] -> [Type]
-    get_constrained_tys tys
+    get_std_constrained_tys :: [Type] -> [Type]
+    get_std_constrained_tys tys
         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
     	| otherwise	  = tys
 
     rep_tc_tvs = tyConTyVars rep_tc
     last_tv = last rep_tc_tvs
-    all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
+    all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
+                      = rep_tc_args ++ [mkTyVarTy last_tv]
     		    | otherwise       = rep_tc_args
 
     	-- Constraints arising from superclasses
@@ -841,10 +879,12 @@ data DerivStatus = CanDerive
 		 | DerivableClassError SDoc	-- Standard class, but can't do it
      		 | NonDerivableClass		-- Non-standard class
 
-checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys rep_tc
+checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
+                    -> TyCon -> [Type] -- tycon and its parameters
+                    -> DerivStatus
+checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
   | Just cond <- sideConditions mtheta cls
-  = case (cond (dflags, rep_tc)) of
+  = case (cond (dflags, rep_tc, rep_tc_args)) of
 	Just err -> DerivableClassError err	-- Class-specific error
 	Nothing  | null cls_tys -> CanDerive	-- All derivable classes are unary, so
 						-- cls_tys (the type args other than last)
@@ -879,17 +919,19 @@ sideConditions mtheta cls
     	                                   cond_functorOK False)
   | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
                                            checkFlag Opt_DeriveGeneric)
+  | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
+                                           checkFlag Opt_DeriveGeneric)
   | otherwise = Nothing
   where
     cls_key = getUnique cls
     cond_std = cond_stdOK mtheta
 
-type Condition = (DynFlags, TyCon) -> Maybe SDoc
-	-- first Bool is whether or not we are allowed to derive Data and Typeable
-	-- second Bool is whether or not we are allowed to derive Functor
-	-- TyCon is the *representation* tycon if the
-	--	data type is an indexed one
-	-- Nothing => OK
+type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
+        -- first Bool is whether or not we are allowed to derive Data and Typeable
+        -- second Bool is whether or not we are allowed to derive Functor
+        -- TyCon is the *representation* tycon if the data type is an indexed one
+        -- [Type] are the type arguments to the (representation) TyCon
+        -- Nothing => OK
 
 orCond :: Condition -> Condition -> Condition
 orCond c1 c2 tc
@@ -910,7 +952,7 @@ cond_stdOK (Just _) _
   = Nothing	-- Don't check these conservative conditions for
 		-- standalone deriving; just generate the code
 		-- and let the typechecker handle the result
-cond_stdOK Nothing (_, rep_tc)
+cond_stdOK Nothing (_, rep_tc, _)
   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
   | otherwise      	= Nothing
@@ -930,7 +972,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
 		     ptext (sLit "must have at least one data constructor")
 
 cond_RepresentableOk :: Condition
-cond_RepresentableOk (_,t) = canDoGenerics t
+cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args
+
+cond_Representable1Ok :: Condition
+cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
 
 cond_enumOrProduct :: Class -> Condition
 cond_enumOrProduct cls = cond_isEnumeration `orCond`
@@ -939,7 +984,7 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
 cond_args :: Class -> Condition
 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 -- by generating specilaised code.  For others (eg Data) we don't.
-cond_args cls (_, tc)
+cond_args cls (_, tc, _)
   = case bad_args of
       []      -> Nothing
       (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
@@ -962,7 +1007,7 @@ cond_args cls (_, tc)
 
 
 cond_isEnumeration :: Condition
-cond_isEnumeration (_, rep_tc)
+cond_isEnumeration (_, rep_tc, _)
   | isEnumerationTyCon rep_tc   = Nothing
   | otherwise		        = Just why
   where
@@ -972,7 +1017,7 @@ cond_isEnumeration (_, rep_tc)
 		  -- See Note [Enumeration types] in TyCon
 
 cond_isProduct :: Condition
-cond_isProduct (_, rep_tc)
+cond_isProduct (_, rep_tc, _)
   | isProductTyCon rep_tc = Nothing
   | otherwise	          = Just why
   where
@@ -983,7 +1028,7 @@ cond_typeableOK :: Condition
 -- OK for Typeable class
 -- Currently: (a) args all of kind *
 --	      (b) 7 or fewer args
-cond_typeableOK (_, tc)
+cond_typeableOK (_, tc, _)
   | tyConArity tc > 7 = Just too_many
   | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
                       = Just bad_kind
@@ -1004,7 +1049,7 @@ cond_functorOK :: Bool -> Condition
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) optionally: don't use function types
 --            (e) no "stupid context" on data type
-cond_functorOK allowFunctions (_, rep_tc)
+cond_functorOK allowFunctions (_, rep_tc, _)
   | null tc_tvs
   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
           <+> ptext (sLit "must have some type parameters"))
@@ -1044,7 +1089,7 @@ cond_functorOK allowFunctions (_, rep_tc)
     wrong_arg 	= ptext (sLit "must use the type variable only as the last argument of a data type")
 
 checkFlag :: ExtensionFlag -> Condition
-checkFlag flag (dflags, _)
+checkFlag flag (dflags, _, _)
   | xopt flag dflags = Nothing
   | otherwise        = Just why
   where
@@ -1065,11 +1110,11 @@ std_class_via_iso clas
 
 
 non_iso_class :: Class -> Bool
--- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism,
 -- even with -XGeneralizedNewtypeDeriving
 non_iso_class cls
   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
-                         , genClassKey] ++ typeableClassKeys)
+                         , genClassKey, gen1ClassKey] ++ typeableClassKeys)
 
 typeableClassKeys :: [Unique]
 typeableClassKeys = map getUnique typeableClassNames
@@ -1138,7 +1183,7 @@ mkNewTypeEqn orig dflags tvs
 				   else Left spec) }
 
   | otherwise
-  = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
+  = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
       CanDerive -> go_for_it 	-- Use the standard H98 method
       DerivableClassError msg 	-- Error with standard class
         | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
@@ -1458,8 +1503,9 @@ the renamer.  What a great hack!
 --
 genInst :: Bool             -- True <=> standalone deriving
         -> OverlapFlag
+        -> CommonAuxiliaries
         -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
-genInst standalone_deriv oflag
+genInst standalone_deriv oflag comauxs
         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype
                  , ds_name = name, ds_cls = clas })
@@ -1471,6 +1517,7 @@ genInst standalone_deriv oflag
   = do { fix_env <- getFixityEnv
        ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) 
                                         fix_env clas name rep_tycon
+                                        (lookup rep_tycon comauxs)
        ; let inst_info = InstInfo { iSpec   = inst_spec
                                   , iBinds  = VanillaInst meth_binds []
                                                 standalone_deriv }
@@ -1495,13 +1542,18 @@ genInst standalone_deriv oflag
 --    co  : N [(b,b)] ~ Tree (b,b)
 
 genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
+              -> Maybe CommonAuxiliary
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc fix_env clas name tycon
+genDerivStuff loc fix_env clas name tycon comaux_maybe
   | className clas `elem` typeableClassNames
   = return (gen_Typeable_binds loc tycon, emptyBag)
 
-  | classKey clas == genClassKey   -- Special case because monadic
-  = gen_Generic_binds tycon (nameModule name)
+  | ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
+  = let gk =  if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One
+        Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
+    in do
+      (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name)
+      return (binds, DerivFamInst faminst `consBag` emptyBag)
 
   | otherwise	                   -- Non-monadic generators
   = do dflags <- getDynFlags
@@ -1509,20 +1561,22 @@ genDerivStuff loc fix_env clas name tycon
         Just gen_fn -> return (gen_fn loc tycon)
         Nothing	    -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
   where
+    ck = classKey clas
+
     gen_list :: DynFlags
              -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
     gen_list dflags
-             = [(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 dflags)
-               ,(functorClassKey,       gen_Functor_binds)
-               ,(foldableClassKey,      gen_Foldable_binds)
-               ,(traversableClassKey,   gen_Traversable_binds)
+             = [(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 dflags)
+               ,(functorClassKey, gen_Functor_binds)
+               ,(foldableClassKey, gen_Foldable_binds)
+               ,(traversableClassKey, gen_Traversable_binds)
                ]
 \end{code}
 
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 27f21c2e25..8745f8e612 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -6,6 +6,7 @@ The deriving code for the Generic class
 (equivalent to the code in TcGenDeriv, for other classes)
 
 \begin{code}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
@@ -14,8 +15,10 @@ The deriving code for the Generic class
 -- for details
 
 
-module TcGenGenerics (canDoGenerics, gen_Generic_binds) where
-
+module TcGenGenerics (canDoGenerics, canDoGenerics1,
+                      GenericKind(..),
+                      MetaTyCons, genGenericMetaTyCons,
+                      gen_Generic_binds, get_gen1_constrained_tys) where
 
 import DynFlags
 import HsSyn
@@ -40,11 +43,15 @@ import HscTypes
 import BuildTyCl
 import SrcLoc
 import Bag
+import VarSet (elemVarSet)
 import Outputable 
 import FastString
 import UniqSupply
 import Util
 
+import Control.Monad (mplus)
+import qualified State as S
+
 #include "HsVersions.h"
 \end{code}
 
@@ -62,19 +69,14 @@ For the generic representation we need to generate:
 \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)
-        ; dflags <- getDynFlags
-        ; return ( mkBindsRep dflags tc
-                 ,           (DerivFamInst rep0TyInst)
-                   `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
-                   `unionBags` metaInsts)) }
-
-genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst)
-genGenericRepExtras tc mod =
+gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
+                 -> TcM (LHsBinds RdrName, FamInst)
+gen_Generic_binds gk tc metaTyCons mod = do
+  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
+  return (mkBindsRep gk tc, repTyInsts)
+
+genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
+genGenericMetaTyCons tc mod =
   do  uniqS <- newUniqueSupply
       let
         -- Uniques for everyone
@@ -110,14 +112,13 @@ genGenericRepExtras tc mod =
                          | s_namesC <- s_names ]
 
           metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
-  
-      rep0_tycon <- tc_mkRepTyCon tc metaDts mod
-      
+
       -- pprTrace "rep0" (ppr rep0_tycon) $
-      return (metaDts, rep0_tycon)
+      (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
 
-genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff
-genDtMeta (tc,metaDts) =
+-- both the tycon declarations and related instances
+metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
+metaTyConsToDerivStuff tc metaDts =
   do  loc <- getSrcSpanM
       dflags <- getDynFlags
       dClas <- tcLookupClass datatypeClassName
@@ -133,7 +134,7 @@ genDtMeta (tc,metaDts) =
 
       let
         safeOverlap = safeLanguageOn dflags
-        (dBinds,cBinds,sBinds) = mkBindsMetaD dflags fix_env tc
+        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
         
         -- Datatype
         d_metaTycon = metaD metaDts
@@ -173,7 +174,8 @@ genDtMeta (tc,metaDts) =
           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))
+      return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts)
+               `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)
 \end{code}
 
 %************************************************************************
@@ -183,25 +185,47 @@ genDtMeta (tc,metaDts) =
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: TyCon -> Maybe SDoc
+get_gen1_constrained_tys :: TyVar -> [Type] -> [Type]
+-- called by TcDeriv.inferConstraints; generates a list of types, each of which
+-- must be a Functor in order for the Generic1 instance to work.
+get_gen1_constrained_tys argVar =
+  concatMap $ argTyFold argVar $ ArgTyAlg {
+    ata_rec0 = const [],
+    ata_par1 = [], ata_rec1 = const [],
+    ata_comp = (:)}
+
+
+
+canDoGenerics :: TyCon -> [Type] -> Maybe SDoc
 -- Called on source-code data types, to see if we should generate
 -- generic functions for them.
 -- Nothing == yes
 -- Just s  == no, because of `s`
 
-canDoGenerics tycon
-  =  mergeErrors (
+canDoGenerics tc tc_args
+  = mergeErrors (
           -- We do not support datatypes with context
-              (if (not (null (tyConStupidTheta tycon)))
-                then (Just (ppr tycon <+> text "must not have a datatype context"))
-                else Nothing)
-          -- We don't like type families
-            : (if (isFamilyTyCon tycon)
-                then (Just (ppr tycon <+> text "must not be a family instance"))
-                else Nothing)
+              (if (not (null (tyConStupidTheta tc)))
+                then (Just (tc_name <+> text "must not have a datatype context"))
+                else Nothing) :
+          -- The type should not be instantiated (see #5939)
+          -- Data family indices can be instantiated; the `tc_args` here are the
+          -- representation tycon args
+              (if (all isTyVarTy tc_args)
+                then Nothing
+                else Just (tc_name <+> text "must not be instantiated;" <+>
+                           text "try deriving `" <> tc_name <+> tc_tys <>
+                           text "' instead"))
           -- See comment below
-            : (map bad_con (tyConDataCons tycon)))
+            : (map bad_con (tyConDataCons tc)))
   where
+    -- The tc can be a representation tycon. When we want to display it to the
+    -- user (in an error message) we should print its parent
+    (tc_name, tc_tys) = case tyConParent tc of
+        FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
+                                            (tys ++ drop (length tys) tc_args)))
+        _                      -> (ppr tc, hsep (map ppr tc_args))
+
         -- If any of the constructor has an unboxed type as argument,
         -- then we can't build the embedding-projection pair, because
         -- it relies on instantiating *polymorphic* sum and product types
@@ -215,13 +239,109 @@ canDoGenerics tycon
 	-- 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)
-    
-    mergeErrors :: [Maybe SDoc] -> Maybe SDoc
-    mergeErrors []           = Nothing
-    mergeErrors ((Just s):t) = case mergeErrors t of
-                                 Nothing -> Just s
-                                 Just s' -> Just (s <> text ", and" $$ s')
-    mergeErrors (Nothing :t) = mergeErrors t
+
+mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+mergeErrors []           = Nothing
+mergeErrors ((Just s):t) = case mergeErrors t of
+  Nothing -> Just s
+  Just s' -> Just (s <> text ", and" $$ s')
+mergeErrors (Nothing :t) = mergeErrors t
+
+canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc
+-- Called on source-code data types, to see if we should generate
+-- generic functions for them.
+-- Nothing == yes
+-- Just s  == no, because of `s`
+
+-- (derived from TcDeriv.cond_functorOK; also checks canDoGenerics)
+
+-- OK for Generic1/Rep1
+-- Currently: (a) at least one argument
+--            (b) don't use argument contravariantly
+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
+--            (d) no "stupid context" on data type
+--            (e) not instantiated (except for data family indices)
+canDoGenerics1 tc tc_args = canDoGenerics tc tc_args
+                              `mplus` S.evalState (canDoGenerics1_w tc) []
+
+-- the state is which tycons we have entered; it avoids divergence when we
+-- recur (robust against mutual recursion)
+canDoGenerics1_w :: TyCon -> S.State [Name] (Maybe SDoc)
+canDoGenerics1_w rep_tc
+  | null tc_tvs
+  = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
+          <+> ptext (sLit "must have some type parameters"))
+
+  | not (null bad_stupid_theta)
+  = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
+          <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
+
+  | otherwise
+  = (mergeErrors . concat) `fmap` mapM check_con data_cons
+  where
+    tc_tvs            = tyConTyVars rep_tc
+    Just (_, last_tv) = snocView tc_tvs
+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
+    is_bad pred       = last_tv `elemVarSet` tyVarsOfType pred
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = case check_vanilla con of
+      j@(Just _) -> return [j]
+      Nothing -> mapM snd $ foldDataConArgs (ft_check con) con
+
+    bad :: DataCon -> SDoc -> SDoc
+    bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
+
+    check_vanilla :: DataCon -> Maybe SDoc
+    check_vanilla con | isVanillaDataCon con = Nothing
+    		      | otherwise	     = Just (bad con existential)
+
+    -- the Bool is if the parameter occurs in the type
+    ft_check :: DataCon -> FFoldType (Bool, S.State [Name] (Maybe SDoc))
+    ft_check con = FT { ft_triv = bmzero, ft_var = (True, return Nothing)
+                      , ft_co_var = (True, return $ Just $ bad con covariant)
+                        -- NB foldDataConArgs caters to Functor/Foldable/etc,
+                        -- which treat applications of functions and tuples
+                        -- specially. But we just treat them like normal
+                        -- applications, so we must compensate with extra logic
+                        -- to ensure that the variable only occurs as the last
+                        -- argument.
+	      	      , ft_fun = \x y -> if fst x then (True, return $ Just $ bad con wrong_arg)
+                                         else x `bmplus` y
+                      , ft_tup = \_ xs ->
+                          if not (null xs) && any fst (init xs)
+                          then (True, return $ Just $ bad con wrong_arg)
+                          else foldr bmplus bmzero xs
+                      , ft_ty_app = \ty x -> bmplus x $ (,) False $
+                          if fst x then representable ty else return Nothing
+                      , ft_bad_app = (True, return $ Just $ bad con wrong_arg)
+                      , ft_forall = \_ -> id }
+
+    bmzero = (False, return Nothing)
+    bmplus (b1, m1) (b2, m2) = (b1 || b2, m1 >>= maybe m2 (return . Just))
+
+    representable :: Type -> S.State [Name] (Maybe SDoc)
+    representable ty = case tcSplitTyConApp_maybe ty of
+      Nothing -> return Nothing
+      -- if it's a type constructor, it has to be representable
+      Just (tc, tc_args) -> do
+        let n = tyConName tc
+        s <- S.get
+        -- internally assume that recursive occurrences are OK
+        if n `elem` s then return Nothing else do
+          S.put (n : s)
+          fmap {-maybe-} (\_ -> bad_app tc) -- don't give the message, just name what wasn't representable
+            `fmap` {-state-} case canDoGenerics tc tc_args of
+              j@(Just _) -> return j
+              -- only check Generic1 if it passes Generic
+              Nothing -> canDoGenerics1_w tc
+
+    existential = (ptext . sLit) "must not have existential arguments"
+    covariant   = (ptext . sLit) "must not use the last type parameter in a function argument"
+    wrong_arg   = (ptext . sLit) "must use the last type parameter only as the last argument of a data type, newtype, or (->)"
+    bad_app tc  = (ptext . sLit) "must not apply type constructors that cannot be represented with `Rep1' (such as `" <> ppr (tyConName tc)
+                  <> (ptext . sLit) "') to arguments that involve the last type parameter"
+
 \end{code}
 
 %************************************************************************
@@ -234,91 +354,212 @@ canDoGenerics tycon
 type US = Int	-- Local unique supply, just a plain Int
 type Alt = (LPat RdrName, LHsExpr RdrName)
 
+-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
+-- Generic1 (Gen1).
+data GenericKind = Gen0 | Gen1
+
+-- as above, but with a payload of the TyCon's name for "the" parameter
+data GenericKind_ = Gen0_ | Gen1_ TyVar
+
+-- as above, but using a single datacon's name for "the" parameter
+data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
+
+forgetArgVar :: GenericKind_DC -> GenericKind
+forgetArgVar Gen0_DC   = Gen0
+forgetArgVar Gen1_DC{} = Gen1
+
+-- When working only within a single datacon, "the" parameter's name should
+-- match that datacon's name for it.
+gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
+gk2gkDC Gen0_   _ = Gen0_DC
+gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
+
+
+
 -- Bindings for the Generic instance
-mkBindsRep :: DynFlags -> TyCon -> LHsBinds RdrName
-mkBindsRep dflags tycon =
-    unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
+mkBindsRep gk tycon = 
+    unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches))
   `unionBags`
-    unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+    unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches))
       where
         from_matches  = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
         to_matches    = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
         loc           = srcLocSpan (getSrcLoc tycon)
         datacons      = tyConDataCons tycon
 
+        (from01_RDR, to01_RDR) = case gk of
+                                   Gen0 -> (from_RDR,  to_RDR)
+                                   Gen1 -> (from1_RDR, to1_RDR)
+
         -- Recurse over the sum first
         from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum dflags (1 :: US) tycon datacons
+        (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
+          where gk_ = case gk of
+                  Gen0 -> Gen0_
+                  Gen1 -> ASSERT (length tyvars >= 1)
+                          Gen1_ (last tyvars)
+                    where tyvars = tyConTyVars tycon
         
 --------------------------------------------------------------------------------
--- The type instance synonym and synonym
+-- The type synonym instance and synonym
 --       type instance Rep (D a b) = Rep_D a b
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepTyCon :: TyCon            -- The type to generate representation for
+tc_mkRepFamInsts ::  GenericKind     -- Gen0 or Gen1
+               -> TyCon           -- The type to generate representation for
                -> MetaTyCons      -- Metadata datatypes to refer to
                -> Module          -- Used as the location of the new RepTy
                -> TcM FamInst     -- Generated representation0 coercion
-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
+tc_mkRepFamInsts gk tycon metaDts mod = 
+       -- Consider the example input tycon `D`, where data D a b = D_ a
+       -- Also consider `R:DInt`, where { data family D x y :: * -> *
+       --                               ; data instance D Int a b = D_ a }
+  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
+       rep <- case gk of
+         Gen0 -> tcLookupTyCon repTyConName
+         Gen1 -> tcLookupTyCon rep1TyConName
 
      ; let -- `tyvars` = [a,b]
-           tyvars     = tyConTyVars tycon
-           tyvar_args = mkTyVarTys tyvars
+           (tyvars, gk_) = case gk of
+             Gen0 -> (all_tyvars, Gen0_)
+             Gen1 -> ASSERT (not $ null all_tyvars)
+                     (init all_tyvars, Gen1_ $ last all_tyvars)
+             where all_tyvars = tyConTyVars tycon
 
-           -- `appT` = D a b
-           appT = [mkTyConApp tycon tyvar_args]
+           tyvar_args = mkTyVarTys tyvars
 
-       -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; rep0Ty <- tc_mkRepTy tycon tyvar_args metaDts
+           appT = case tyConFamInst_maybe tycon of
+                     -- `appT` = D Int a b (data families case)
+                     Just (famtycon, apps) ->
+                       -- `fam` = D
+                       -- `apps` = [Int, a]
+                       let allApps = apps ++
+                                     drop (length apps + length tyvars
+                                           - tyConArity famtycon) tyvar_args
+                       in [mkTyConApp famtycon allApps]
+                     -- `appT` = D a b (normal case)
+                     Nothing -> [mkTyConApp tycon tyvar_args]
+
+       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+     ; repTy <- tc_mkRepTy gk_ tycon metaDts
     
        -- `rep_name` is a name we generate for the synonym
-     ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
-                     (nameSrcSpan (tyConName tycon))
+     ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
+                   in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
+                        (nameSrcSpan (tyConName tycon))
 
-     ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
+     ; return $ mkSynFamInst rep_name tyvars rep appT repTy
      }
 
-
-
 --------------------------------------------------------------------------------
 -- Type representation
 --------------------------------------------------------------------------------
 
-tc_mkRepTy :: -- The type to generate representation for, and instantiating types
-               TyCon -> [Type]    
+-- | See documentation of 'argTyFold'; that function uses the fields of this
+-- type to interpret the structure of a type when that type is considered as an
+-- argument to a constructor that is being represented with 'Rep1'.
+data ArgTyAlg a = ArgTyAlg
+  { ata_rec0 :: (Type -> a)
+  , ata_par1 :: a, ata_rec1 :: (Type -> a)
+  , ata_comp :: (Type -> a -> a)
+  }
+
+-- | @argTyFold@ implements a generalised and safer variant of the @arg@
+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
+-- is conceptually equivalent to:
+--
+-- > arg t = case t of
+-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
+-- >   App f [t'] |
+--       representable1 f &&
+--       t' == argVar        -> Rec1 f
+-- >   App f [t'] |
+--       representable1 f &&
+--       t' has tyvars       -> f :.: (arg t')
+-- >   _                     -> Rec0 t
+--
+-- where @argVar@ is the last type variable in the data type declaration we are
+-- finding the representation for.
+--
+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
+-- @:.:@.
+--
+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
+-- some data types. The problematic case is when @t@ is an application of a
+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
+-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
+-- representable1 checks have been relaxed, and others were moved to
+-- @canDoGenerics1@.
+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
+                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
+                            ata_comp = mkComp}) =
+  -- mkRec0 is the default; use it if there is no interesting structure
+  -- (e.g. occurrences of parameters or recursive occurrences)
+  \t -> maybe (mkRec0 t) id $ go t where
+  go :: Type -> -- type to fold through
+        Maybe a -- the result (e.g. representation type), unless it's trivial
+  go t = isParam `mplus` isApp where
+
+    isParam = do -- handles parameters
+      t' <- getTyVar_maybe t
+      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
+             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
+
+    isApp = do -- handles applications
+      (phi, beta) <- tcSplitAppTy_maybe t
+
+      let interesting = argVar `elemVarSet` exactTyVarsOfType beta
+
+      -- Does it have no interesting structure to represent?
+      if not interesting then Nothing
+        else -- Is the argument the parameter? Special case for mkRec1.
+          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
+            else mkComp phi `fmap` go beta -- It must be a composition.
+
+
+tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
+               GenericKind_
+              -- The type to generate representation for
+            -> TyCon
                -- Metadata datatypes to refer to
             -> MetaTyCons 
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy tycon ty_args metaDts = 
+tc_mkRepTy gk_ tycon metaDts = 
   do
     d1    <- tcLookupTyCon d1TyConName
     c1    <- tcLookupTyCon c1TyConName
     s1    <- tcLookupTyCon s1TyConName
     nS1   <- tcLookupTyCon noSelTyConName
     rec0  <- tcLookupTyCon rec0TyConName
-    par0  <- tcLookupTyCon par0TyConName
+    rec1  <- tcLookupTyCon rec1TyConName
+    par1  <- tcLookupTyCon par1TyConName
     u1    <- tcLookupTyCon u1TyConName
     v1    <- tcLookupTyCon v1TyConName
     plus  <- tcLookupTyCon sumTyConName
     times <- tcLookupTyCon prodTyConName
+    comp  <- tcLookupTyCon compTyConName
     
     let mkSum' a b = mkTyConApp plus  [a,b]
         mkProd a b = mkTyConApp times [a,b]
+        mkComp a b = mkTyConApp comp  [a,b]
         mkRec0 a   = mkTyConApp rec0  [a]
-        mkPar0 a   = mkTyConApp par0  [a]
+        mkRec1 a   = mkTyConApp rec1  [a]
+        mkPar1     = mkTyConTy  par1
         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
-        mkC  i d a = mkTyConApp c1    [d, prod i (dataConInstOrigArgTys a ty_args) 
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon)
                                                  (null (dataConFieldLabels a))]
         -- This field has no label
         mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
         -- This field has a  label
         mkS False d a = mkTyConApp s1 [d, a]
         
+        -- Sums and products are done in the same way for both Rep and Rep1
         sumP [] = mkTyConTy v1
         sumP l  = ASSERT (length metaCTyCons == length l)
                     foldBal mkSum' [ mkC i d a
@@ -334,12 +575,21 @@ tc_mkRepTy tycon ty_args metaDts =
                                          | (d,t) <- zip (metaSTyCons !! i) l ]
         
         arg :: Type -> Type -> Bool -> Type
-        arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
-        -- Argument is not a type variable, use Rec0
-        recOrPar t Nothing  = mkRec0 t
-        -- Argument is a type variable, use Par0
-        recOrPar t (Just _) = mkPar0 t
+        arg d t b = mkS b d $ case gk_ of 
+            -- Here we previously used Par0 if t was a type variable, but we
+            -- realized that we can't always guarantee that we are wrapping-up
+            -- all type variables in Par0. So we decided to stop using Par0
+            -- altogether, and use Rec0 all the time.
+                      Gen0_        -> mkRec0 t
+                      Gen1_ argVar -> argPar argVar t
+          where
+            -- Builds argument represention for Rep1 (more complicated due to
+            -- the presence of composition).
+            argPar argVar = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
+               ata_rec1 = mkRec1, ata_comp = mkComp}
         
+       
         metaDTyCon  = mkTyConTy (metaD metaDts)
         metaCTyCons = map mkTyConTy (metaC metaDts)
         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
@@ -365,11 +615,11 @@ metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
 
 
 -- Bindings for Datatype, Constructor, and Selector instances
-mkBindsMetaD :: DynFlags -> FixityEnv -> TyCon 
+mkBindsMetaD :: FixityEnv -> TyCon 
              -> ( LHsBinds RdrName      -- Datatype instance
                 , [LHsBinds RdrName]    -- Constructor instances
                 , [[LHsBinds RdrName]]) -- Selector instances
-mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
       where
         mkBag l = foldr1 unionBags 
                     [ unitBag (L loc (mkFunBind (L loc name) matches)) 
@@ -401,24 +651,28 @@ mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         datacons      = tyConDataCons tycon
         datasels      = map dataConFieldLabels datacons
 
-        dtName_matches     = mkStringLHS . showPpr dflags . nameOccName . tyConName 
-                           $ tycon
+        tyConName_user = case tyConFamInst_maybe tycon of
+                           Just (ptycon, _) -> tyConName ptycon
+                           Nothing          -> tyConName tycon
+
+        dtName_matches     = mkStringLHS . occNameString . nameOccName
+                           $ tyConName_user
         moduleName_matches = mkStringLHS . moduleNameString . moduleName 
                            . nameModule . tyConName $ tycon
 
-        conName_matches     c = mkStringLHS . showPpr dflags . nameOccName
+        conName_matches     c = mkStringLHS . occNameString . nameOccName
                               . dataConName $ c
         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 
-        selName_matches     s = mkStringLHS (showPpr dflags (nameOccName s))
+        selName_matches     s = mkStringLHS (occNameString (nameOccName s))
 
 
 --------------------------------------------------------------------------------
 -- Dealing with sums
 --------------------------------------------------------------------------------
 
-mkSum :: DynFlags
+mkSum :: GenericKind_ -- Generic or Generic1?
       -> US          -- Base for generating unique names
       -> TyCon       -- The type constructor
       -> [DataCon]   -- The data constructors
@@ -426,42 +680,62 @@ mkSum :: DynFlags
           [Alt])     -- Alternatives for the Trep->T "to" function
 
 -- Datatype without any constructors
-mkSum dflags _us tycon [] = ([from_alt], [to_alt])
+mkSum _ _ tycon [] = ([from_alt], [to_alt])
   where
     from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
     to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
                -- These M1s are meta-information for the datatype
     makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
-    errMsgFrom = "No generic representation for empty datatype " ++ showPpr dflags tycon
-    errMsgTo = "No values for empty datatype " ++ showPpr dflags tycon
+    tyConStr   = occNameString (nameOccName (tyConName tycon))
+    errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
+    errMsgTo   = "No values for empty datatype " ++ tyConStr
 
 -- Datatype with at least one constructor
-mkSum _ us _tycon datacons =
-  unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+mkSum gk_ us _ datacons =
+  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
+           | (d,i) <- zip datacons [1..] ]
 
 -- Build the sum for a particular constructor
-mk1Sum :: US        -- Base for generating unique names
+mk1Sum :: GenericKind_DC -- Generic or Generic1?
+       -> US        -- Base for generating unique names
        -> Int       -- The index of this constructor
        -> Int       -- Total number of constructors
        -> DataCon   -- The data constructor
        -> (Alt,     -- Alternative for the T->Trep "from" function
            Alt)     -- Alternative for the Trep->T "to" function
-mk1Sum us i n datacon = (from_alt, to_alt)
+mk1Sum gk_ us i n datacon = (from_alt, to_alt)
   where
-    n_args = dataConSourceArity datacon	-- Existentials already excluded
+    gk = forgetArgVar gk_
+
+    -- Existentials already excluded
+    argTys = dataConOrigArgTys datacon
+    n_args = dataConSourceArity datacon
 
-    datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
+    datacon_vars = map fst datacon_varTys
     us'          = us + n_args
 
     datacon_rdr  = getRdrName datacon
-    app_exp      = nlHsVarApps datacon_rdr datacon_vars
     
     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-    from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
+    from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
     
-    to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+    to_alt     = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
                  -- These M1s are meta-information for the datatype
-    to_alt_rhs = app_exp
+    to_alt_rhs = case gk_ of
+      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
+      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
+        where
+          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
+            converter = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = const $ nlHsVar unK1_RDR,
+               ata_par1 = nlHsVar unPar1_RDR,
+               ata_rec1 = const $ nlHsVar unRec1_RDR,
+               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
+                                    `nlHsCompose` nlHsVar unComp1_RDR}
+
+
 
 -- Generates the L1/R1 sum pattern
 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
@@ -486,34 +760,47 @@ genLR_E i n e
 --------------------------------------------------------------------------------
 
 -- Build a product expression
-mkProd_E :: US	            -- Base for unique names
-	 -> [RdrName]       -- List of variables matched on the lhs
+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
-mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
-mkProd_E _ vars = mkM1_E (foldBal prod appVars)
-                   -- These M1s are meta-information for the constructor
+mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
   where
-    appVars = map wrapArg_E vars
+    appVars = map (wrapArg_E gk_) varTys
     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
 
-wrapArg_E :: RdrName -> LHsExpr RdrName
-wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
-              -- This M1 is meta-information for the selector
+wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
+wrapArg_E Gen0_DC          (var, _)  = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
+                         -- This M1 is meta-information for the selector
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
+                         -- This M1 is meta-information for the selector
+  where converter = argTyFold argVar $ ArgTyAlg
+          {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
+           ata_par1 = nlHsVar par1DataCon_RDR,
+           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
+           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
+                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}
+
+
 
 -- Build a product pattern
-mkProd_P :: US		        -- Base for unique names
+mkProd_P :: GenericKind   -- Gen0 or Gen1
+         -> US		        -- Base for unique names
 	       -> [RdrName]     -- List of variables to match
 	       -> LPat RdrName  -- Resulting product pattern
-mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
-mkProd_P _ vars = mkM1_P (foldBal prod appVars)
-                   -- These M1s are meta-information for the constructor
+mkProd_P _  _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
   where
-    appVars = map wrapArg_P vars
+    appVars = map (wrapArg_P gk) vars
     prod a b = prodDataCon_RDR `nlConPat` [a,b]
-    
-wrapArg_P :: RdrName -> LPat RdrName
-wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
-              -- This M1 is meta-information for the selector
+
+wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
+wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+                   -- This M1 is meta-information for the selector
+wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
@@ -524,6 +811,9 @@ mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 mkM1_P :: LPat RdrName -> LPat RdrName
 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
 
+nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
+
 -- | Variant of foldr1 for producing balanced lists
 foldBal :: (a -> a -> a) -> [a] -> a
 foldBal op = foldBal' op (error "foldBal: empty list")