Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
authorJose Pedro Magalhaes <jpm@cs.uu.nl>
Mon, 2 May 2011 18:48:10 +0000 (20:48 +0200)
committerJose Pedro Magalhaes <jpm@cs.uu.nl>
Mon, 2 May 2011 18:48:10 +0000 (20:48 +0200)
34 files changed:
compiler/basicTypes/MkId.lhs
compiler/basicTypes/OccName.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/HscStats.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/Class.lhs
compiler/types/Generics.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/vectorise/Vectorise/Type/PData.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs

index 5aebd37..a251734 100644 (file)
@@ -13,7 +13,7 @@ have a standard form, namely:
 
 \begin{code}
 module MkId (
-        mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+        mkDictFunId, mkDictFunTy, mkDictSelId,
 
         mkDataConIds,
         mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
@@ -826,11 +826,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
 that they aren't discarded by the occurrence analyser.
 
 \begin{code}
-mkDefaultMethodId :: Id                -- Selector Id
-                 -> Name       -- Default method name
-                 -> Id         -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
 mkDictFunId :: Name      -- Name to use for the dict fun;
             -> [TyVar]
             -> ThetaType
index 5489ea7..8940692 100644 (file)
@@ -48,11 +48,12 @@ module OccName (
 
        -- ** Derived 'OccName's
         isDerivedOccName,
-       mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
+       mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
        mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
        mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
        mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+       mkGenD, mkGenR0, mkGenR0Co, mkGenC, mkGenS,
        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
        mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
        mkInstTyCoOcc, mkEqPredCoOcc,
@@ -539,9 +540,10 @@ isDerivedOccName occ =
 \end{code}
 
 \begin{code}
-mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
-       mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
-       mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
+       mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
+       mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+       mkGenD, mkGenR0, mkGenR0Co,
        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
        mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
@@ -553,6 +555,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
 mkDataConWrapperOcc = mk_simple_deriv varName  "$W"
 mkWorkerOcc         = mk_simple_deriv varName  "$w"
 mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"
+mkGenDefMethodOcc   = mk_simple_deriv varName  "$gdm"
 mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"
 mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies
 mkClassTyConOcc     = mk_simple_deriv tcName   "T:"    -- as a tycon/datacon
@@ -571,10 +574,23 @@ mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
 mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"
 mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"
 
--- Generic derivable classes
+-- Generic derivable classes (old)
 mkGenOcc1           = mk_simple_deriv varName  "$gfrom"
 mkGenOcc2           = mk_simple_deriv varName  "$gto" 
 
+-- Generic deriving mechanism (new)
+mkGenD         = mk_simple_deriv tcName "D1"
+
+mkGenC :: OccName -> Int -> OccName
+mkGenC occ m   = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+
+mkGenS :: OccName -> Int -> Int -> OccName
+mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
+                   (occNameString occ)
+
+mkGenR0   = mk_simple_deriv tcName "Rep0_"
+mkGenR0Co = mk_simple_deriv tcName "CoRep0_"
+
 -- data T = MkT ... deriving( Data ) needs defintions for 
 --     $tT   :: Data.Generics.Basics.DataType
 --     $cMkT :: Data.Generics.Basics.Constr
index e34c696..611a231 100644 (file)
@@ -420,6 +420,7 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
 rep_sig (L loc (TypeSig nm ty))       = rep_proto nm ty loc
+rep_sig (L loc (GenericSig nm ty))    = rep_proto nm ty loc -- JPM: ?
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 rep_sig _                             = return []
index 675afa2..9ebede6 100644 (file)
@@ -597,6 +597,10 @@ data Sig name      -- Signatures and pragmas
        -- f :: Num a => a -> a
     TypeSig (Located name) (LHsType name)
 
+        -- A type signature for a generic function inside a class
+        -- generic eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
+  | GenericSig (Located name) (LHsType name)
+
        -- A type signature in generated code, notably the code
        -- generated for record selectors.  We simply record
        -- the desired Id itself, replete with its name, type
@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool
 okBindSig _ = True
 
 okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig  _ _) = True
-okHsBootSig (FixSig _)            = True
-okHsBootSig _              = False
+okHsBootSig (TypeSig  _ _)    = True
+okHsBootSig (GenericSig  _ _) = True -- JPM: Is this true?
+okHsBootSig (FixSig _)               = True
+okHsBootSig _                 = False
 
 okClsDclSig :: Sig a -> Bool
 okClsDclSig (SpecInstSig _) = False
 okClsDclSig _               = True        -- All others OK
 
 okInstDclSig :: Sig a -> Bool
-okInstDclSig (TypeSig _ _)   = False
-okInstDclSig (FixSig _)      = False
-okInstDclSig _                      = True
+okInstDclSig (TypeSig _ _)    = False
+okInstDclSig (GenericSig _ _) = False
+okInstDclSig (FixSig _)       = False
+okInstDclSig _                       = True
 
 sigName :: LSig name -> Maybe name
 -- Used only in Haddock
@@ -702,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True
 isVanillaLSig _                 = False
 
 isTypeLSig :: LSig name -> Bool         -- Type signatures
-isTypeLSig (L _(TypeSig {})) = True
-isTypeLSig (L _(IdSig {}))   = True
-isTypeLSig _                 = False
+isTypeLSig (L _(TypeSig {}))    = True
+isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(IdSig {}))      = True
+isTypeLSig _                    = False
 
 isSpecLSig :: LSig name -> Bool
 isSpecLSig (L _(SpecSig {})) = True
@@ -727,6 +734,7 @@ isInlineLSig _                    = False
 
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})          = ptext (sLit "type signature")
+hsSigDoc (GenericSig {})       = ptext (sLit "generic default type signature")
 hsSigDoc (IdSig {})            = ptext (sLit "id signature")
 hsSigDoc (SpecSig {})          = ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
@@ -741,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 eqHsSig (L _ (IdSig n1))               (L _ (IdSig n2))                = n1 == n2
 eqHsSig (L _ (TypeSig n1 _))           (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
+eqHsSig (L _ (GenericSig n1 _))                (L _ (GenericSig n2 _))         = unLoc n1 == unLoc n2
 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
        -- For specialisations, we don't have equality over
        -- HsType, so it's not convenient to spot duplicate 
@@ -754,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 ppr_sig (TypeSig var ty)         = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (GenericSig var ty)      = ptext (sLit "generic") <+> pprVarSig (unLoc var) (ppr ty)
 ppr_sig (IdSig id)               = pprVarSig id (ppr (varType id))
 ppr_sig (FixSig fix_sig)         = ppr fix_sig
 ppr_sig (SpecSig var ty inl)     = pragBrackets (pprSpec var (ppr ty) inl)
index 53d2949..c05f26a 100644 (file)
@@ -834,7 +834,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
 \begin{code}
 type LDerivDecl name = Located (DerivDecl name)
 
-data DerivDecl name = DerivDecl (LHsType name)
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
   deriving (Data, Typeable)
 
 instance (OutputableBndr name) => Outputable (DerivDecl name) where
index 13f3cd7..ad0f30f 100644 (file)
@@ -27,7 +27,7 @@ module HsUtils(
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
 
-  -- Bindigns
+  -- Bindings
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, 
 
   -- Literals
index b1c97cd..993159b 100644 (file)
@@ -1291,7 +1291,7 @@ instance Binary IfaceDecl where
            put_ bh idinfo
     put_ _ (IfaceForeign _ _) = 
        error "Binary.put_(IfaceDecl): IfaceForeign"
-    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
            putByte bh 2
            put_ bh (occNameFS a1)
            put_ bh a2
@@ -1300,7 +1300,6 @@ instance Binary IfaceDecl where
            put_ bh a5
            put_ bh a6
            put_ bh a7
-           put_ bh a8
     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
            putByte bh 3
            put_ bh (occNameFS a1)
@@ -1335,9 +1334,8 @@ instance Binary IfaceDecl where
                    a5 <- get bh
                    a6 <- get bh
                    a7 <- get bh
-                   a8 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                   return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+                   return (IfaceData occ a2 a3 a4 a5 a6 a7)
              3 -> do
                    a1 <- get bh
                    a2 <- get bh
index e71eefe..9522024 100644 (file)
@@ -59,13 +59,12 @@ buildAlgTyCon :: Name -> [TyVar]
              -> ThetaType              -- ^ Stupid theta
              -> AlgTyConRhs
              -> RecFlag
-             -> Bool                   -- ^ True <=> want generics functions
              -> Bool                   -- ^ True <=> was declared in GADT syntax
               -> TyConParent
              -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
              -> TcRnIf m n TyCon
 
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
              parent mb_family
   | Just fam_inst_info <- mb_family
   = -- We need to tie a knot as the coercion of a data instance depends
@@ -74,11 +73,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
     fixM $ \ tycon_rec -> do 
     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
     ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
-                        fam_parent is_rec want_generics gadt_syn) }
+                        fam_parent is_rec gadt_syn) }
 
   | otherwise
   = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
-                      parent is_rec want_generics gadt_syn)
+                      parent is_rec gadt_syn)
   where
     kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 
@@ -229,8 +228,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 \begin{code}
-type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
-                                            -- between tcClassSigs and buildClass
+type TcMethInfo = (Name, DefMethSpec, Type)  
+        -- A temporary intermediate, to communicate between tcClassSigs and
+        -- buildClass.
 
 buildClass :: Bool             -- True <=> do not include unfoldings 
                                --          on dict selectors
@@ -332,7 +332,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
     mk_op_item rec_clas (op_name, dm_spec, _) 
       = do { dm_info <- case dm_spec of
                           NoDM      -> return NoDefMeth
-                          GenericDM -> return GenDefMeth
+                          GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
+                                         ; return (GenDefMeth dm_name) }
                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
                                          ; return (DefMeth dm_name) }
            ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
index 3eae7a3..ea1ace8 100644 (file)
@@ -67,14 +67,6 @@ data IfaceDecl
                ifRec        :: RecFlag,        -- Recursive or not?
                ifGadtSyntax :: Bool,           -- True <=> declared using
                                                -- GADT syntax 
-               ifGeneric    :: Bool,           -- True <=> generic converter
-                                               --          functions available
-                                               -- We need this for imported
-                                               -- data decls, since the
-                                               -- imported modules may have
-                                               -- been compiled with
-                                               -- different flags to the
-                                               -- current compilation unit 
                 ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
                                                 -- Just <=> instance of family
                                                 -- Invariant: 
@@ -471,11 +463,11 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
   = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (dcolon <+> ppr kind)
 
-pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
+pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
                         ifTyVars = tyvars, ifCons = condecls, 
                         ifRec = isrec, ifFamInst = mbFamInst})
   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
-       4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
+       4 (vcat [pprRec isrec, pp_condecls tycon condecls,
                pprFamily mbFamInst])
   where
     pp_nd = case condecls of
@@ -495,10 +487,6 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 pprRec :: RecFlag -> SDoc
 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
 
-pprGen :: Bool -> SDoc
-pprGen True  = ptext (sLit "Generics: yes")
-pprGen False = ptext (sLit "Generics: no")
-
 pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
 pprFamily Nothing        = ptext (sLit "FamilyInstance: none")
 pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
index c327006..847e7c7 100644 (file)
@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
          op_ty                = funResultTy rho_ty
 
-    toDmSpec NoDefMeth   = NoDM
-    toDmSpec GenDefMeth  = GenericDM
-    toDmSpec (DefMeth _) = VanillaDM
+    toDmSpec NoDefMeth      = NoDM
+    toDmSpec (GenDefMeth _) = GenericDM
+    toDmSpec (DefMeth _)    = VanillaDM
 
     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
 
@@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon)
                ifCons    = ifaceConDecls (algTyConRhs tycon),
                ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                ifGadtSyntax = isGadtSyntaxTyCon tycon,
-               ifGeneric = tyConHasGenerics tycon,
                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
 
   | isForeignTyCon tycon
index 8dccc72..a4da138 100644 (file)
@@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                          ifCons = rdr_cons, 
                          ifRec = is_rec, 
-                         ifGeneric = want_generic,
                          ifFamInst = mb_family })
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
@@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
            ; mb_fam_inst  <- tcFamInst mb_family
            ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
-                           want_generic gadt_syn parent mb_fam_inst
+                           gadt_syn parent mb_fam_inst
            })
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
index 7e15aa4..ed64fd0 100644 (file)
@@ -321,7 +321,7 @@ data ExtensionFlag
    | Opt_TemplateHaskell
    | Opt_QuasiQuotes
    | Opt_ImplicitParams
-   | Opt_Generics                      -- "Derivable type classes"
+   | Opt_Generics                      -- generic deriving mechanism
    | Opt_ImplicitPrelude
    | Opt_ScopedTypeVariables
    | Opt_UnboxedTuples
@@ -343,6 +343,7 @@ data ExtensionFlag
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
+   | Opt_DeriveRepresentable
 
    | Opt_TypeSynonymInstances
    | Opt_FlexibleContexts
@@ -1677,6 +1678,7 @@ xFlags = [
   ( "DeriveFunctor",                    Opt_DeriveFunctor, nop ),
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
+  ( "DeriveRepresentable",              Opt_DeriveRepresentable, nop ),
   ( "TypeSynonymInstances",             Opt_TypeSynonymInstances, nop ),
   ( "FlexibleContexts",                 Opt_FlexibleContexts, nop ),
   ( "FlexibleInstances",                Opt_FlexibleInstances, nop ),
@@ -1857,6 +1859,7 @@ glasgowExtsFlags = [
            , Opt_DeriveFunctor
            , Opt_DeriveFoldable
            , Opt_DeriveTraversable
+           , Opt_DeriveRepresentable
            , Opt_FlexibleContexts
            , Opt_FlexibleInstances
            , Opt_ConstrainedClassMethods
index b96eb56..d902626 100644 (file)
@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                ("InstType         ", inst_type_ds),
                ("InstData         ", inst_data_ds),
                ("TypeSigs         ", bind_tys),
+               ("GenericSigs      ", generic_sigs),
                ("ValBinds         ", val_bind_ds),
                ("FunBinds         ", fn_bind_ds),
                ("InlineMeths      ", method_inlines),
@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     
     trim ls     = takeWhile (not.isSpace) (dropWhile isSpace ls)
 
-    (fixity_sigs, bind_tys, bind_specs, bind_inlines) 
+    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs
        = count_sigs [d | SigD d <- decls]
                -- NB: this omits fixity decls on local bindings and
                -- in class decls.  ToDo
@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     count_bind (FunBind {})                           = (0,1)
     count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
 
-    count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+    count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
 
-    sig_info (FixSig _)                = (1,0,0,0)
-    sig_info (TypeSig _ _)      = (0,1,0,0)
-    sig_info (SpecSig _ _ _)    = (0,0,1,0)
-    sig_info (InlineSig _ _)    = (0,0,0,1)
-    sig_info _                  = (0,0,0,0)
+    sig_info (FixSig _)                = (1,0,0,0,0)
+    sig_info (TypeSig _ _)      = (0,1,0,0,0)
+    sig_info (SpecSig _ _ _)    = (0,0,1,0,0)
+    sig_info (InlineSig _ _)    = (0,0,0,1,0)
+    sig_info (GenericSig _ _)   = (0,0,0,0,1)
+    sig_info _                  = (0,0,0,0,0)
 
     import_info (L _ (ImportDecl _ _ _ qual as spec))
        = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     class_info decl@(ClassDecl {})
        = case count_sigs (map unLoc (tcdSigs decl)) of
-           (_,classops,_,_) ->
+           (_,classops,_,_,_) ->
               (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info _ = (0,0)
 
     inst_info (InstDecl _ inst_meths inst_sigs ats)
        = case count_sigs (map unLoc inst_sigs) of
-           (_,_,ss,is) ->
+           (_,_,ss,is,_) ->
              case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
                (tyDecl, dtDecl) ->
                  (addpr (foldr add2 (0,0) 
@@ -157,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     addpr :: (Int,Int) -> Int
     add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
-    add4  :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
     add5  :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
     add6  :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
 
     addpr (x,y) = x+y
     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-    add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
     add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
 \end{code}
index a2d2276..338af4c 100644 (file)
@@ -335,11 +335,6 @@ $tab+         { warn Opt_WarnTabs (text "Warning: Tab character") }
          { token ITcubxparen }
 }
 
-<0> {
-  "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
-  "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
-}
-
 <0,option_prags> {
   \(                                   { special IToparen }
   \)                                   { special ITcparen }
@@ -1751,8 +1746,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
 -- integer
 
-genericsBit :: Int
-genericsBit = 0 -- {| and |}
+-- The "genericsBit" is now unused, available for others
+-- genericsBit :: Int
+-- genericsBit = 0 -- {|, |} and "generic"
+
 ffiBit :: Int
 ffiBit    = 1
 parrBit :: Int
@@ -1803,8 +1800,6 @@ nondecreasingIndentationBit = 25
 
 always :: Int -> Bool
 always           _     = True
-genericsEnabled :: Int -> Bool
-genericsEnabled  flags = testBit flags genericsBit
 parrEnabled :: Int -> Bool
 parrEnabled      flags = testBit flags parrBit
 arrowsEnabled :: Int -> Bool
@@ -1873,8 +1868,7 @@ mkPState flags buf loc =
       alr_justClosedExplicitLetBlock = False
     }
     where
-      bitmap =     genericsBit       `setBitIf` xopt Opt_Generics flags
-               .|. ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
+      bitmap =     ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
                .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
                .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
                .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
index bfadfba..e009071 100644 (file)
@@ -721,6 +721,11 @@ decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
 decl_cls  : at_decl_cls                        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
          | decl                        { $1 }
 
+         -- A 'default' signature used with the generic-programming extension
+          | 'default' infixexp '::' sigtypedoc
+                    {% do { (TypeSig l ty) <- checkValSig $2 $4
+                          ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
 decls_cls :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
          : decls_cls ';' decl_cls      { LL (unLoc $1 `appOL` unLoc $3) }
          | decls_cls ';'               { LL (unLoc $1) }
@@ -1232,9 +1237,11 @@ gdrh :: { LGRHS RdrName }
        : '|' guardquals '=' exp        { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-       : infixexp '::' sigtypedoc      {% do s <- checkValSig $1 $3 
-                                        ; return (LL $ unitOL (LL $ SigD s)) }
-               -- See Note [Declaration/signature overlap] for why we need infixexp here
+        : 
+       -- See Note [Declaration/signature overlap] for why we need infixexp here
+         infixexp '::' sigtypedoc
+                        {% do s <- checkValSig $1 $3 
+                        ; return (LL $ unitOL (LL $ SigD s)) }
        | var ',' sig_vars '::' sigtypedoc
                                { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
index 47abf23..7aa2654 100644 (file)
@@ -812,17 +812,20 @@ checkValSig lhs@(L l _) ty
                        ppr lhs <+> text "::" <+> ppr ty)
                    $$ text hint)
   where
-    hint = if looks_like_foreign lhs
+    hint = if foreign_RDR `looks_like` lhs
            then "Perhaps you meant to use -XForeignFunctionInterface?"
-           else "Should be of form <variable> :: <type>"
+           else if generic_RDR `looks_like` lhs
+                then "Perhaps you meant to use -XGenerics?"
+                else "Should be of form <variable> :: <type>"
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
-    looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
-    looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
-    looks_like_foreign _                   = False
+    looks_like s (L _ (HsVar v))     = v == s
+    looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
+    looks_like _ _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
+    generic_RDR = mkUnqual varName (fsLit "generic")
 
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool
index 24756d5..c334bce 100644 (file)
@@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey
 %*                                                                      *
 %************************************************************************
 
-This section tells what the compiler knows about the assocation of
+This section tells what the compiler knows about the association of
 names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
 
@@ -221,10 +221,25 @@ basicKnownKeyNames
        -- dotnet interop
        , objectTyConName, marshalObjectName, unmarshalObjectName
        , marshalStringName, unmarshalStringName, checkDotnetResName
+       
+       -- Generics
+       , rep0ClassName, rep1ClassName
+       , datatypeClassName, constructorClassName, selectorClassName
+       
     ]
 
 genericTyConNames :: [Name]
-genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
+genericTyConNames = [
+    -- Old stuff
+    crossTyConName, plusTyConName, genUnitTyConName,
+    -- New stuff
+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+    compTyConName, rTyConName, pTyConName, dTyConName,
+    cTyConName, sTyConName, rec0TyConName, par0TyConName,
+    d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+    rep0TyConName, rep1TyConName
+  ]
 
 -- Know names from the DPH package which vary depending on the selected DPH backend.
 --
@@ -525,12 +540,60 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
 
+error_RDR :: RdrName
+error_RDR = varQual_RDR gHC_ERR (fsLit "error")
+
+-- Old Generics (constructors and functions)
 crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
 crossDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")
 inlDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Inl")
 inrDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Inr")
 genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit")
 
+-- Generics (constructors and functions)
+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
+  prodDataCon_RDR, comp1DataCon_RDR, from0_RDR, from1_RDR,
+  to0_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,
+  rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+
+--v1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "V1")
+u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")
+par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")
+rec1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Rec1")
+k1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "K1")
+m1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "M1")
+
+l1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "L1")
+r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")
+
+prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")
+comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
+
+from0_RDR = varQual_RDR gHC_GENERICS (fsLit "from0")
+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
+to0_RDR   = varQual_RDR gHC_GENERICS (fsLit "to0")
+to1_RDR   = varQual_RDR gHC_GENERICS (fsLit "to1")
+
+datatypeName_RDR  = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
+moduleName_RDR    = varQual_RDR gHC_GENERICS (fsLit "moduleName")
+selName_RDR       = varQual_RDR gHC_GENERICS (fsLit "selName")
+conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")
+conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")
+conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
+
+noArityDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
+arityDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Arity")
+prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
+infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")
+leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
+rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
+notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+
+
 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
 fmap_RDR               = varQual_RDR gHC_BASE (fsLit "fmap")
 pure_RDR               = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
@@ -576,12 +639,47 @@ eitherTyConName     = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey
 leftDataConName   = conName dATA_EITHER (fsLit "Left")   leftDataConKey
 rightDataConName  = conName dATA_EITHER (fsLit "Right")  rightDataConKey
 
--- Generics
+-- Old Generics (types)
 crossTyConName, plusTyConName, genUnitTyConName :: Name
 crossTyConName     = tcQual   gHC_GENERICS (fsLit ":*:") crossTyConKey
 plusTyConName      = tcQual   gHC_GENERICS (fsLit ":+:") plusTyConKey
 genUnitTyConName   = tcQual   gHC_GENERICS (fsLit "Unit") genUnitTyConKey
 
+-- Generics (types)
+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+  compTyConName, rTyConName, pTyConName, dTyConName, 
+  cTyConName, sTyConName, rec0TyConName, par0TyConName,
+  d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+  rep0TyConName, rep1TyConName :: Name
+
+v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
+u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
+par1TyConName  = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
+rec1TyConName  = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
+k1TyConName  = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
+m1TyConName  = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
+
+sumTyConName    = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey
+prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
+compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
+
+rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey
+pTyConName  = tcQual gHC_GENERICS (fsLit "P") pTyConKey
+dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey
+cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey
+sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey
+
+rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
+par0TyConName  = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
+d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
+c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
+s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
+noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
+
+rep0TyConName = tcQual gHC_GENERICS (fsLit "Rep0") rep0TyConKey
+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
+
 -- Base strings Strings
 unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
     unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
@@ -755,6 +853,16 @@ showClassName        = clsQual gHC_SHOW (fsLit "Show")       showClassKey
 readClassName :: Name
 readClassName     = clsQual gHC_READ (fsLit "Read") readClassKey
 
+-- Classes Representable0 and Representable1, Datatype, Constructor and Selector
+rep0ClassName, rep1ClassName, datatypeClassName, constructorClassName,
+  selectorClassName :: Name
+rep0ClassName = clsQual gHC_GENERICS (fsLit "Representable0") rep0ClassKey
+rep1ClassName = clsQual gHC_GENERICS (fsLit "Representable1") rep1ClassKey
+
+datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
+constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
+selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
+
 -- parallel array types and functions
 enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
     singletonPName, replicatePName, mapPName, filterPName,
@@ -944,6 +1052,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique
 applicativeClassKey    = mkPreludeClassUnique 34
 foldableClassKey       = mkPreludeClassUnique 35
 traversableClassKey    = mkPreludeClassUnique 36
+
+rep0ClassKey, rep1ClassKey, datatypeClassKey, constructorClassKey,
+  selectorClassKey :: Unique
+rep0ClassKey  = mkPreludeClassUnique 37
+rep1ClassKey  = mkPreludeClassUnique 38
+
+datatypeClassKey    = mkPreludeClassUnique 39
+constructorClassKey = mkPreludeClassUnique 40
+selectorClassKey    = mkPreludeClassUnique 41
 \end{code}
 
 %************************************************************************
@@ -1029,7 +1146,7 @@ ptrTyConKey                               = mkPreludeTyConUnique 74
 funPtrTyConKey                         = mkPreludeTyConUnique 75
 tVarPrimTyConKey                       = mkPreludeTyConUnique 76
 
--- Generic Type Constructors
+-- Old Generic Type Constructors
 crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
 crossTyConKey                          = mkPreludeTyConUnique 79
 plusTyConKey                           = mkPreludeTyConUnique 80
@@ -1086,6 +1203,41 @@ opaqueTyConKey                          = mkPreludeTyConUnique 133
 stringTyConKey :: Unique
 stringTyConKey                         = mkPreludeTyConUnique 134
 
+-- Generics (Unique keys)
+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
+  compTyConKey, rTyConKey, pTyConKey, dTyConKey,
+  cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+  d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
+  rep0TyConKey, rep1TyConKey :: Unique
+
+v1TyConKey    = mkPreludeTyConUnique 135
+u1TyConKey    = mkPreludeTyConUnique 136
+par1TyConKey  = mkPreludeTyConUnique 137
+rec1TyConKey  = mkPreludeTyConUnique 138
+k1TyConKey    = mkPreludeTyConUnique 139
+m1TyConKey    = mkPreludeTyConUnique 140
+
+sumTyConKey   = mkPreludeTyConUnique 141
+prodTyConKey  = mkPreludeTyConUnique 142
+compTyConKey  = mkPreludeTyConUnique 143
+
+rTyConKey = mkPreludeTyConUnique 144
+pTyConKey = mkPreludeTyConUnique 145
+dTyConKey = mkPreludeTyConUnique 146
+cTyConKey = mkPreludeTyConUnique 147
+sTyConKey = mkPreludeTyConUnique 148
+
+rec0TyConKey  = mkPreludeTyConUnique 149
+par0TyConKey  = mkPreludeTyConUnique 150
+d1TyConKey    = mkPreludeTyConUnique 151
+c1TyConKey    = mkPreludeTyConUnique 152
+s1TyConKey    = mkPreludeTyConUnique 153
+noSelTyConKey = mkPreludeTyConUnique 154
+
+rep0TyConKey = mkPreludeTyConUnique 155
+rep1TyConKey = mkPreludeTyConUnique 156
+
 ---------------- Template Haskell -------------------
 --     USES TyConUniques 200-299
 -----------------------------------------------------
index db2ea1b..e0d23dd 100644 (file)
@@ -211,7 +211,6 @@ pcTyCon is_enum is_rec name tyvars cons
                (DataTyCon cons is_enum)
                NoParentTyCon
                 is_rec
-               True            -- All the wired-in tycons have generics
                False           -- Not in GADT syntax
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
@@ -276,7 +275,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA
 mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
 mk_tuple boxity arity = (tycon, tuple_con)
   where
-       tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info 
+       tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity 
        modu    = mkTupleModule boxity arity
        tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
                                (ATyCon tycon) BuiltInSyntax
@@ -293,8 +292,6 @@ mk_tuple boxity arity = (tycon, tuple_con)
                                  (ADataCon tuple_con) BuiltInSyntax
        tc_uniq   = mkTupleTyConUnique   boxity arity
        dc_uniq   = mkTupleDataConUnique boxity arity
-       gen_info  = True                -- Tuples all have generics..
-                                       -- hmm: that's a *lot* of code
 
 unitTyCon :: TyCon
 unitTyCon     = tupleTyCon Boxed 0
index df3b12d..b0dd3b5 100644 (file)
@@ -591,8 +591,20 @@ rnMethodBinds :: Name                      -- Class name
              -> RnM (LHsBinds Name, FreeVars)
 
 rnMethodBinds cls sig_fn gen_tyvars binds
-  = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+  = do { checkDupRdrNames meth_names
+            -- Check that the same method is not given twice in the
+            -- same instance decl      instance C T where
+            --                       f x = ...
+            --                       g y = ...
+            --                       f x = ...
+            -- We must use checkDupRdrNames because the Name of the
+            -- method is the Name of the class selector, whose SrcSpan
+            -- points to the class declaration; and we use rnMethodBinds
+            -- for instance decls too
+
+       ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
   where 
+    meth_names  = collectMethodBinders binds
     do_one (binds,fvs) bind 
        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
            ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
@@ -668,7 +680,12 @@ renameSigs mb_names ok_sig sigs
                -- Check for duplicates on RdrName version, 
                -- because renamed version has unboundName for
                -- not-in-scope binders, which gives bogus dup-sig errors
-
+               -- NB: in a class decl, a 'generic' sig is not considered 
+               --     equal to an ordinary sig, so we allow, say
+               --           class C a where
+               --             op :: a -> a
+               --             generic op :: Eq a => a -> a
+               
        ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
 
        ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
@@ -695,6 +712,13 @@ renameSig mb_names sig@(TypeSig v ty)
        ; new_ty <- rnHsSigType (quotes (ppr v)) ty
        ; return (TypeSig new_v new_ty) }
 
+renameSig mb_names sig@(GenericSig v ty)
+  = do { generics_on <- xoptM Opt_Generics
+        ; unless generics_on (addErr (genericSigErr sig))
+        ; new_v <- lookupSigOccRn mb_names sig v
+       ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+       ; return (GenericSig new_v new_ty) } -- JPM: ?
+
 renameSig _ (SpecInstSig ty)
   = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
        ; return (SpecInstSig new_ty) }
@@ -816,6 +840,11 @@ misplacedSigErr (L loc sig)
   = addErrAt loc $
     sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
 
+genericSigErr :: Sig RdrName -> SDoc
+genericSigErr sig = vcat [ hang (ptext (sLit "Unexpected generic default signature:"))
+                              2 (ppr sig)
+                         , ptext (sLit "Use -XGenerics to enable generic default signatures") ] 
+
 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
 methodBindErr mbind
  =  hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
@@ -830,4 +859,5 @@ nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
 nonStdGuardErr guards
   = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
        4 (interpp'SP guards)
+
 \end{code}
index 9226cb4..44aa700 100644 (file)
@@ -120,10 +120,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars
 hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
 
 hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty)   = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
-hsSigFVs _                = emptyFVs
+hsSigFVs (TypeSig _ ty)    = extractHsTyNames ty
+hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
+hsSigFVs (SpecInstSig ty)  = extractHsTyNames ty
+hsSigFVs (SpecSig _ ty _)  = extractHsTyNames ty
+hsSigFVs _                 = emptyFVs
 
 ----------------
 conDeclFVs :: LConDecl Name -> FreeVars
index 18c2dfd..e08f65e 100644 (file)
@@ -443,19 +443,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
        -- The typechecker (not the renamer) checks that all 
        -- the bindings are for the right class
     let
-       meth_names  = collectMethodBinders mbinds
        (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
     in
-    checkDupRdrNames meth_names        `thenM_`
-       -- Check that the same method is not given twice in the
-       -- same instance decl   instance C T where
-       --                            f x = ...
-       --                            g y = ...
-       --                            f x = ...
-       -- We must use checkDupRdrNames because the Name of the
-       -- method is the Name of the class selector, whose SrcSpan
-       -- points to the class declaration
-
     extendTyVarEnvForMethodBinds inst_tyvars (         
        -- (Slightly strangely) the forall-d tyvars scope over
        -- the method bindings too
index 8db89b9..fe7cb81 100644 (file)
@@ -8,19 +8,15 @@ Typechecking class declarations
 \begin{code}
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
                    findMethodBind, instantiateMethod, tcInstanceMethodBody,
-                   mkGenericDefMethBind, getGenericInstances, 
+                   mkGenericDefMethBind,
                    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
                  ) where
 
 #include "HsVersions.h"
 
 import HsSyn
-import RnHsSyn
-import RnExpr
-import Inst
-import InstEnv
-import TcPat( addInlinePrags )
 import TcEnv
+import TcPat( addInlinePrags )
 import TcBinds
 import TcUnify
 import TcHsType
@@ -28,21 +24,13 @@ import TcMType
 import TcType
 import TcRnMonad
 import BuildTyCl( TcMethInfo )
-import Generics
 import Class
-import TyCon
-import MkId
 import Id
 import Name
 import Var
-import NameEnv
-import NameSet
 import Outputable
-import PrelNames
 import DynFlags
 import ErrUtils
-import Util
-import ListSetOps
 import SrcLoc
 import Maybes
 import BasicTypes
@@ -50,7 +38,6 @@ import Bag
 import FastString
 
 import Control.Monad
-import Data.List
 \end{code}
 
 
@@ -97,48 +84,36 @@ Death to "ExpandingDicts".
 tcClassSigs :: Name                    -- Name of the class
            -> [LSig Name]
            -> LHsBinds Name
-           -> TcM [TcMethInfo]
+           -> TcM [TcMethInfo]    -- One for each method
 
 tcClassSigs clas sigs def_methods
-  = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names)) 
-                        (bagToList def_methods)
-       ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
-  where
-    op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
-    op_names = [n   |     (L _ (TypeSig (L _ n) _)) <- op_sigs]
-
-checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
-  -- Check default bindings
-  --   a) must be for a class op for this class
-  --   b) must be all generic or all non-generic
-checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
-  = do {       -- Check that the op is from this class
-        checkTc (op `elem` ops) (badMethodErr clas op)
-
-       -- Check that all the defns ar generic, or none are
-       ; case (none_generic, all_generic) of
-           (True, _) -> return (op, VanillaDM)
-           (_, True) -> return (op, GenericDM)
-           _         -> failWith (mixedGenericErr op)
-    }
-  where
-    n_generic    = count (isJust . maybeGenericMatch) matches
-    none_generic = n_generic == 0
-    all_generic  = matches `lengthIs` n_generic
+  = do { -- Check that all def_methods are in the class
+       ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
+       ; let op_names = [ n | (n,_,_) <- op_info ]
 
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+       ; sequence_ [ failWithTc (badMethodErr clas n)
+                   | n <- dm_bind_names, not (n `elem` op_names) ]
+                  -- Value binding for non class-method (ie no TypeSig)
 
+       ; sequence_ [ failWithTc (badGenericMethod clas n)
+                   | n <- genop_names, not (n `elem` dm_bind_names) ]
+                  -- Generic signature without value binding
 
-tcClassSig :: NameEnv DefMethSpec      -- Info about default methods; 
-          -> LSig Name
-          -> TcM TcMethInfo
-
-tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
-  = setSrcSpan loc $ do
-    { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
-    ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
-    ; return (op_name, dm, op_ty) }
-tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
+       ; return op_info }
+  where
+    dm_bind_names :: [Name]    -- These ones have a value binding in the class decl
+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+    genop_names :: [Name]   -- These ones have a generic signature
+    genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
+
+    tc_sig (TypeSig (L _ op_name) op_hs_ty)
+      = do { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
+           ; let dm | op_name `elem` genop_names   = GenericDM
+                    | op_name `elem` dm_bind_names = VanillaDM
+                    | otherwise                    = NoDM
+           ; return (op_name, dm, op_ty) }
+    tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
 \end{code}
 
 
@@ -174,62 +149,88 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
        ; this_dict <- newEvVar pred
 
+       ; traceTc "TIM2" (ppr sigs)
        ; let tc_dm = tcDefMeth clas clas_tyvars
-                               this_dict default_binds
+                               this_dict default_binds sigs
                                sig_fn prag_fn
 
        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                       mapM tc_dm op_items
 
-       ; return (listToBag (catMaybes dm_binds)) }
+       ; return (unionManyBags dm_binds) }
 
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
           -> SigFun -> PragFun -> ClassOpItem
-          -> TcM (Maybe (LHsBind Id))
+          -> TcM (LHsBinds TcId)
 -- Generate code for polymorphic default methods only (hence DefMeth)
 -- (Generic default methods have turned into instance decls by now.)
 -- This is incompatible with Hugs, which expects a polymorphic 
 -- default method for every class op, regardless of whether or not 
 -- the programmer supplied an explicit default decl for the class.  
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
   = case dm_info of
-      NoDefMeth       -> return Nothing
-      GenDefMeth      -> return Nothing
-      DefMeth dm_name -> do
-       { let sel_name = idName sel_id
-       ; local_dm_name <- newLocalName sel_name
-         -- Base the local_dm_name on the selector name, because
-         -- type errors from tcInstanceMethodBody come from here
-
-               -- See Note [Silly default-method bind]
-               -- (possibly out of date)
-
-       ; let meth_bind = findMethodBind sel_name binds_in
-                         `orElse` pprPanic "tcDefMeth" (ppr sel_id)
-               -- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
-             dm_sig_fn  _  = sig_fn sel_name
-             dm_id         = mkDefaultMethodId sel_id dm_name
-             local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
-             local_dm_id   = mkLocalId local_dm_name local_dm_type
-              prags         = prag_fn sel_name
-
-        ; dm_id_w_inline <- addInlinePrags dm_id prags
-        ; spec_prags     <- tcSpecPrags dm_id prags
-
-        ; warnTc (not (null spec_prags))
-                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
-                  <+> quotes (ppr sel_name))
-
-        ; liftM Just $
-          tcInstanceMethodBody (ClsSkol clas)
-                               tyvars 
-                               [this_dict]
-                               dm_id_w_inline local_dm_id
-                               dm_sig_fn IsDefaultMethod meth_bind }
+      NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+                               ; return emptyBag }
+      DefMeth dm_name    -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
+      GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
+                               ; tc_dm dm_name tau } 
+           -- In the case of a generic default, we have to get the type from the signature
+           -- Otherwise we can get it by instantiating the method selector
+  where
+    sel_name      = idName sel_id
+    prags         = prag_fn sel_name
+    dm_sig_fn  _  = sig_fn sel_name
+    dm_bind       = findMethodBind sel_name binds_in
+                   `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+    -- Eg.   class C a where
+    --          op :: forall b. Eq b => a -> [b] -> a
+    --         gen_op :: a -> a
+    --                 generic gen_op :: D a => a -> a
+    -- The "local_dm_ty" is precisely the type in the above
+    -- type signatures, ie with no "forall a. C a =>" prefix
+
+    tc_dm dm_name local_dm_ty
+      = do { local_dm_name <- newLocalName sel_name
+            -- Base the local_dm_name on the selector name, because
+            -- type errors from tcInstanceMethodBody come from here
+
+          ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
+                dm_id = mkExportedLocalId dm_name dm_ty
+                local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+           ; dm_id_w_inline <- addInlinePrags dm_id prags
+           ; spec_prags     <- tcSpecPrags dm_id prags
+
+           ; warnTc (not (null spec_prags))
+                    (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                     <+> quotes (ppr sel_name))
+
+           ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+                                             dm_id_w_inline local_dm_id dm_sig_fn 
+                                             IsDefaultMethod dm_bind
+
+           ; return (unitBag tc_bind) }
+
+    tc_genop_ty :: LHsType Name -> TcM Type
+    tc_genop_ty hs_ty 
+       = setSrcSpan (getLoc hs_ty) $
+         do { tau <- tcHsKindedType hs_ty
+            ; checkValidType (FunSigCtxt sel_name) tau 
+            ; return tau }
+
+findGenericSig :: [LSig Name] -> Name -> LHsType Name
+-- Find the 'generic op :: ty' signature among the sigs
+-- If dm_info is GenDefMeth, the corresponding signature
+-- should jolly well exist!  Hence the panic
+findGenericSig sigs sel_name 
+  = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+         , n == sel_name ] of
+      [lty] -> lty
+      _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
 
 ---------------
 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
@@ -246,7 +247,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
           let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                              -- Substitute the local_meth_name for the binder
                             -- NB: the binding is always a FunBind
-
+        ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) 
        ; (ev_binds, (tc_bind, _)) 
                <- checkConstraints skol_info tyvars dfun_ev_vars $
                  tcExtendIdEnv [local_meth_id] $
@@ -359,179 +360,22 @@ gives rise to the instance declarations
          op Unit      = ...
 
 \begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
   =    -- A generic default method
-       -- If the method is defined generically, we can only do the job if the
-       -- instance declaration is for a single-parameter type class with
-       -- a type constructor applied to type arguments in the instance decl
-       --      (checkTc, so False provokes the error)
-    do { checkTc (isJust maybe_tycon)
-                 (badGenericInstance sel_id (notSimple inst_tys))
-       ; checkTc (tyConHasGenerics tycon)
-                 (badGenericInstance sel_id (notGeneric tycon))
-
-       ; dflags <- getDOpts
+       -- If the method is defined generically, we only have to call the
+        -- dm_name.
+    do { dflags <- getDOpts
        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
                   (vcat [ppr clas <+> ppr inst_tys,
                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
-               -- Rename it before returning it
-       ; (rn_rhs, _) <- rnLExpr rhs
         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
-                                    [mkSimpleMatch [] rn_rhs]) }
-  where
-    rhs = mkGenericRhs sel_id clas_tyvar tycon
-
-         -- The tycon is only used in the generic case, and in that
-         -- case we require that the instance decl is for a single-parameter
-         -- type class with type variable arguments:
-         --    instance (...) => C (T a b)
-    clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
-    Just tycon = maybe_tycon
-    maybe_tycon = case inst_tys of 
-                       [ty] -> case tcSplitTyConApp_maybe ty of
-                                 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
-                                 _                                               -> Nothing
-                       _ -> Nothing
-
-
----------------------------
-getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] 
-getGenericInstances class_decls
-  = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
-       ; let { gen_inst_info = concat gen_inst_infos }
-
-       -- Return right away if there is no generic stuff
-       ; if null gen_inst_info then return []
-         else do 
-
-       -- Otherwise print it out
-        { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
-                                2 (vcat (map pprInstInfoDetails gen_inst_info))
-       ; return gen_inst_info }}
-
-get_generics :: TyClDecl Name -> TcM [InstInfo Name]
-get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
-  | null generic_binds
-  = return [] -- The comon case: no generic default methods
-
-  | otherwise  -- A source class decl with generic default methods
-  = recoverM (return [])                                $
-    tcAddDeclCtxt decl                                  $ do
-    clas <- tcLookupLocatedClass class_name
-
-       -- Group by type, and
-       -- make an InstInfo out of each group
-    let
-       groups = groupWith listToBag generic_binds
-
-    inst_infos <- mapM (mkGenericInstance clas) groups
-
-       -- Check that there is only one InstInfo for each type constructor
-       -- The main way this can fail is if you write
-       --      f {| a+b |} ... = ...
-       --      f {| x+y |} ... = ...
-       -- Then at this point we'll have an InstInfo for each
-       --
-       -- The class should be unary, which is why simpleInstInfoTyCon should be ok
-    let
-       tc_inst_infos :: [(TyCon, InstInfo Name)]
-       tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
-       bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
-                             group `lengthExceeds` 1]
-       get_uniq (tc,_) = getUnique tc
-
-    mapM_ (addErrTc . dupGenericInsts) bad_groups
-
-       -- Check that there is an InstInfo for each generic type constructor
-    let
-       missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
-
-    checkTc (null missing) (missingGenericInstances missing)
-
-    return inst_infos
+                                    [mkSimpleMatch [] rhs]) }
   where
-    generic_binds :: [(HsType Name, LHsBind Name)]
-    generic_binds = getGenericBinds def_methods
-get_generics decl = pprPanic "get_generics" (ppr decl)
-
-
----------------------------------
-getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
-  -- Takes a group of method bindings, finds the generic ones, and returns
-  -- them in finite map indexed by the type parameter in the definition.
-getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-
-getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
-getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
-  = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
-  where
-    wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
-getGenericBind _
-  = []
-
-groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
-groupWith _  []         = []
-groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
-    where
-      vs              = map snd this
-      (this,rest)     = partition same_t prs
-      same_t (t', _v) = t `eqPatType` t'
-
-eqPatLType :: LHsType Name -> LHsType Name -> Bool
-eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
-
-eqPatType :: HsType Name -> HsType Name -> Bool
--- A very simple equality function, only for 
--- type patterns in generic function definitions.
-eqPatType (HsTyVar v1)       (HsTyVar v2)      = v1==v2
-eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)   = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
-eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
-eqPatType (HsNumTy n1)      (HsNumTy n2)       = n1 == n2
-eqPatType (HsParTy t1)      t2                 = unLoc t1 `eqPatType` t2
-eqPatType t1                (HsParTy t2)       = t1 `eqPatType` unLoc t2
-eqPatType _ _ = False
-
----------------------------------
-mkGenericInstance :: Class
-                 -> (HsType Name, LHsBinds Name)
-                 -> TcM (InstInfo Name)
-
-mkGenericInstance clas (hs_ty, binds) = do
-  -- Make a generic instance declaration
-  -- For example:      instance (C a, C b) => C (a+b) where { binds }
-
-       -- Extract the universally quantified type variables
-       -- and wrap them as forall'd tyvars, so that kind inference
-       -- works in the standard way
-    let
-       sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
-                  extractHsTyVars (noLoc hs_ty)
-       hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-
-       -- Type-check the instance type, and check its form
-    forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
-    let
-       (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
-
-    checkTc (validGenericInstanceType inst_ty)
-            (badGenericInstanceType binds)
-
-       -- Make the dictionary function.
-    span <- getSrcSpanM
-    overlap_flag <- getOverlapFlag
-    dfun_name <- newDFunName clas [inst_ty] span
-    let
-       inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
-       dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
-        ispec      = mkLocalInstance dfun_id overlap_flag
-
-    return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
+    rhs = nlHsVar dm_name
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
                Error messages
@@ -562,6 +406,11 @@ badMethodErr clas op
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
          ptext (sLit "does not have a method"), quotes (ppr op)]
 
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
+         ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
 badATErr :: Class -> Name -> SDoc
 badATErr clas at
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
@@ -570,23 +419,7 @@ badATErr clas at
 omittedATWarn :: Name -> SDoc
 omittedATWarn at
   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
-  = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
-        because]
-
-notSimple :: [Type] -> SDoc
-notSimple inst_tys
-  = vcat [ptext (sLit "because the instance type(s)"), 
-         nest 2 (ppr inst_tys),
-         ptext (sLit "is not a simple type of form (T a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
-  = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+> 
-         ptext (sLit "was not compiled with -XGenerics")]
-
+{-
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
@@ -604,8 +437,10 @@ dupGenericInsts tc_inst_infos
     ]
   where 
     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
-  = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+-}
+badDmPrag :: Id -> Sig Name -> TcM ()
+badDmPrag sel_id prag
+  = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") 
+              <+> quotes (ppr sel_id) 
+              <+> ptext (sLit "lacks an accompanying binding"))
 \end{code}
index 1798be3..2bd438d 100644 (file)
@@ -40,10 +40,13 @@ 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
@@ -125,6 +128,9 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
            <+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+  ppr = pprDerivSpec
 \end{code}
 
 
@@ -292,17 +298,21 @@ 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)
+            -> 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
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
+  = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
     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 <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+       ; (early_specs, genericsExtras) 
+                <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+        ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
 
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
@@ -313,14 +323,31 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
        ; insts2 <- mapM (genInst False overlap_flag) final_specs
 
-                -- Generate the generic to/from functions from each type declaration
-       ; gen_binds <- mkGenericBinds is_boot tycl_decls
-       ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
-
+       -- 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
+       
+{-
+        -- Generate the generic Representable0 instances
+         -- from each type declaration
+        ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
+       
+       ; let repInsts   = concat (map (\(a,_,_) -> a) repInstsMeta)
+             repMetaTys = map (\(_,b,_) -> b) repInstsMeta
+             repTyCons  = map (\(_,_,c) -> c) repInstsMeta
+-}
+       ; (inst_info, rn_binds, rn_dus)
+                <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts {- ++ repInsts -})
+
+       ; dflags <- getDOpts
+       ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                (ddump_deriving inst_info rn_binds))
+{-
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-
-       ; return (inst_info, rn_binds, rn_dus) }
+-}
+       ; return ( inst_info, rn_binds, rn_dus
+                 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
   where
     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
     ddump_deriving inst_infos extra_binds
@@ -328,6 +355,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
            2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
               $$ ppr extra_binds)
 
+
 renameDeriv :: Bool -> LHsBinds RdrName
            -> [(InstInfo RdrName, DerivAuxBinds)]
            -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
@@ -387,6 +415,7 @@ renameDeriv is_boot gen_binds insts
          clas_nm            = className clas
 
 -----------------------------------------
+{- Now unused 
 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 mkGenericBinds is_boot tycl_decls
   | is_boot 
@@ -399,6 +428,7 @@ mkGenericBinds is_boot tycl_decls
                -- We are only interested in the data type declarations,
                -- and then only in the ones whose 'has-generics' flag is on
                -- The predicate tyConHasGenerics finds both of these
+-}
 \end{code}
 
 Note [Newtype deriving and unused constructors]
@@ -430,21 +460,95 @@ stored in NewTypeDerived.
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 
 \begin{code}
+-- Make the EarlyDerivSpec for Representable0
+mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec)
+mkGenDerivSpec tc = do
+        { cls           <- tcLookupClass rep0ClassName
+        ; let tc_tvs    = tyConTyVars tc
+        ; let tc_app    = mkTyConApp tc (mkTyVarTys tc_tvs)
+        ; let cls_tys   = []
+        ; let mtheta    = Just []
+        ; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta
+        -- JPM TODO: StandAloneDerivOrigin?...
+        ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds }
+
+-- 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]
+              -> [LInstDecl Name]
               -> [LDerivDecl Name] 
-              -> TcM [EarlyDerivSpec]
-
+              -> TcM [EarlyDerivSpec]
+                      , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
 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
-       ; return (eqns1 ++ eqns2) }
+        -- Generate EarlyDerivSpec's for Representable, if asked for
+       ; (xGenerics, xDeriveRepresentable) <- genericsFlags
+       ; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+        ; allTyDecls <- mapM tcLookupTyCon allTyNames
+        -- Select only those types that derive Representable
+        ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+                                       , getClassName c == Just rep0ClassName ]
+        ; let sel_deriv_decls = catMaybes [ getTypeName t
+                                  | L _ (DerivDecl (L _ t)) <- deriv_decls
+                                  , getClassName t == Just rep0ClassName ] 
+        ; derTyDecls <- mapM tcLookupTyCon $ 
+                         filter (needsExtras xDeriveRepresentable
+                                  (sel_tydata ++ sel_deriv_decls)) allTyNames
+        -- We need to generate the extras to add to what has
+        -- already been derived
+        ; generic_extras_deriv <- mapM mkGenDerivExtras derTyDecls
+        -- For the remaining types, if Generics is on, we need to
+        -- generate both the instances and the extras, but only for the
+        -- types we can represent.
+        ; let repTyDecls = filter canDoGenerics allTyDecls
+        ; let remTyDecls = filter (\x -> not (x `elem` derTyDecls)) repTyDecls
+        ; generic_instances    <- if xGenerics
+                                   then mapM mkGenDerivSpec   remTyDecls
+                                    else return []
+        ; generic_extras_flag  <- if xGenerics
+                                   then mapM mkGenDerivExtras remTyDecls
+                                    else return []
+        -- Merge and return everything
+       ; {- pprTrace "allTyDecls" (ppr allTyDecls) $ 
+         pprTrace "derTyDecls" (ppr derTyDecls) $ 
+         pprTrace "repTyDecls" (ppr repTyDecls) $ 
+         pprTrace "remTyDecls" (ppr remTyDecls) $ 
+         pprTrace "xGenerics"  (ppr xGenerics) $ 
+         pprTrace "xDeriveRep" (ppr xDeriveRepresentable) $ 
+         pprTrace "all_tydata" (ppr all_tydata) $ 
+         pprTrace "eqns1" (ppr eqns1) $ 
+         pprTrace "eqns2" (ppr eqns2) $ 
+-}
+          return ( eqns1 ++ eqns2 ++ generic_instances
+                 , generic_extras_deriv ++ generic_extras_flag) }
   where
+    needsExtras xDeriveRepresentable tydata tc_name = 
+      -- We need extras if the flag DeriveGenerics is on and this type is 
+      -- deriving Representable
+      xDeriveRepresentable && tc_name `elem` tydata
+
+    -- Extracts the name of the class in the deriving
+    getClassName :: HsType Name -> Maybe Name
+    getClassName (HsPredTy (HsClassP n _)) = Just n
+    getClassName _                         = Nothing
+
+    -- Extracts the name of the type in the deriving
+    getTypeName :: HsType Name -> Maybe Name
+    getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
+    getTypeName _                                         = Nothing
+
     extractTyDataPreds decls
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 
@@ -459,6 +563,11 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
                        addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
                                   2 (ptext (sLit "Use an instance declaration instead")))
 
+genericsFlags :: TcM (Bool, Bool)
+genericsFlags = do dOpts <- getDOpts
+                   return ( xopt Opt_Generics            dOpts
+                          , xopt Opt_DeriveRepresentable dOpts)
+
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
 -- Standalone deriving declarations
@@ -727,6 +836,11 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy
 -- 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
+  -- Representable0 constraints are easy
+  | cls `hasKey` rep0ClassKey
+  = []
+  -- 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
@@ -830,6 +944,9 @@ sideConditions mtheta cls
                                           cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
                                           cond_functorOK False)
+  | cls_key == rep0ClassKey        = Just (cond_RepresentableOk `andCond`
+                                           (checkFlag Opt_DeriveRepresentable `orCond`
+                                            checkFlag Opt_Generics))
   | otherwise = Nothing
   where
     cls_key = getUnique cls
@@ -880,6 +997,11 @@ no_cons_why :: TyCon -> SDoc
 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> 
                     ptext (sLit "has no data constructors")
 
+-- JPM TODO: should give better error message
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) | canDoGenerics t = Nothing
+                           | otherwise       = Just (ptext (sLit "Cannot derive Representable for type") <+> ppr t)
+
 cond_enumOrProduct :: Condition
 cond_enumOrProduct = cond_isEnumeration `orCond` 
                       (cond_isProduct `andCond` cond_noUnliftedArgs)
@@ -999,11 +1121,11 @@ std_class_via_iso clas
 
 
 non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read,Show,Typeable,Data,Representable0 by isomorphism,
 -- even with -XGeneralizedNewtypeDeriving
 non_iso_class cls 
-  = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
-                        typeableClassKeys)
+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+                         , rep0ClassKey] ++ typeableClassKeys)
 
 typeableClassKeys :: [Unique]
 typeableClassKeys = map getUnique typeableClassNames
@@ -1453,20 +1575,177 @@ genDerivBinds loc fix_env clas tycon
        Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
   where
     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
-    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)
+    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)
+              ,(rep0ClassKey,          gen_Rep0_binds)
               ]
 \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 Representable0 instance
+\item A Rep0 type instance 
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@gen_Rep0_binds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericRepBind@ does all of them
+
+\begin{code}
+{-
+genGenericRepBinds :: Bool -> [LTyClDecl Name] 
+                   -> TcM [([(InstInfo RdrName, DerivAuxBinds)]
+                           , MetaTyCons, TyCon)]
+genGenericRepBinds isBoot tyclDecls
+  | isBoot    = return []
+  | otherwise = do
+      allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls
+                                       , isDataDecl d ]
+      let tyDecls = filter tyConHasGenerics allTyDecls
+      inst1 <- mapM genGenericRepBind tyDecls
+      let (_repInsts, metaTyCons, _repTys) = unzip3 inst1
+      metaInsts <- ASSERT (length tyDecls == length metaTyCons)
+                     mapM genDtMeta (zip tyDecls metaTyCons)
+      return (ASSERT (length inst1 == length metaInsts)
+                [ (ri : mi, ms, rt) 
+                | ((ri, ms, rt), mi) <- zip inst1 metaInsts ])
+-}
+
+gen_Rep0_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Rep0_binds _ tc = (mkBindsRep0 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 [] [] mkAbstractTyConRhs
+                           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_mkRep0TyCon tc metaDts
+
+      return (metaDts, rep0_tycon)
+{-
+genGenericRepBind :: TyCon
+                  -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericRepBind tc =
+  do  (metaDts, rep0_tycon)     <- genGenericRepExtras tc
+      clas                      <- tcLookupClass rep0ClassName
+      dfun_name                 <- new_dfun_name clas tc
+      let
+        mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds }
+                               , [ {- No DerivAuxBinds -} ])
+        inst  = mkLocalInstance dfun NoOverlap
+        binds = VanillaInst (mkBindsRep0 tc) [] False
+
+        tvs   = tyConTyVars tc
+        tc_ty = mkTyConApp tc (mkTyVarTys tvs)
+        
+        dfun  = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
+      return (mkInstRep0, metaDts, rep0_tycon)
+-}
+genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
+genDtMeta (tc,metaDts) =
+  do  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
+        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+        
+        -- Datatype
+        d_metaTycon = metaD metaDts
+        d_inst = mkLocalInstance d_dfun NoOverlap
+        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 
+                  | (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))
+                    (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)
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
index 354e4b2..b5884a7 100644 (file)
@@ -211,7 +211,7 @@ tcLookupFamInst tycon tys
        }
 
 tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
--- Find the instance of a data famliy
+-- Find the instance of a data family
 -- Note [Looking up family instances for deriving]
 tcLookupDataFamInst tycon tys
   | not (isFamilyTyCon tycon)
@@ -461,7 +461,7 @@ tcExtendGlobalTyVars gtv_var extra_global_tvs
 \begin{code}
 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
        -- Just pop the new rules into the EPS and envt resp
-       -- All the rules come from an interface file, not soruce
+       -- All the rules come from an interface file, not source
        -- Nevertheless, some may be for this module, if we read
        -- its interface instead of its source code
 tcExtendRules lcl_rules thing_inside
@@ -681,7 +681,7 @@ newDFunName clas tys loc
 \end{code}
 
 Make a name for the representation tycon of a family instance.  It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
 newGlobalBinder.
 
 \begin{code}
index efacac2..676c3f9 100644 (file)
@@ -42,7 +42,7 @@ import Name
 import HscTypes
 import PrelInfo
 import MkCore  ( eRROR_ID )
-import PrelNames
+import PrelNames hiding (error_RDR)
 import PrimOp
 import SrcLoc
 import TyCon
index 3bb27a7..1462179 100644 (file)
@@ -206,7 +206,7 @@ Just <blah>.
 Instead, we simply rely on the fact that casts are cheap:
 
    $df :: forall a. C a => C [a]
-   {-# INLINE df #}  -- NB: INLINE this
+   {-# INLINE df #-}  -- NB: INLINE this
    $df = /\a. \d. MkC [a] ($cop_list a d)
        = $cop_list |> forall a. C a -> (sym (Co:C [a]))
 
@@ -370,7 +370,6 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
-             ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
              ; implicit_things = concatMap implicitTyThings at_idx_tycons
             ; aux_binds       = mkRecSelBinds at_idx_tycons
              }
@@ -379,31 +378,32 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 --     tythings to the global environment
        ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
 
-                -- (3) Instances from generic class declarations
-       ; generic_inst_info <- getGenericInstances clas_decls
 
                 -- Next, construct the instance environment so far, consisting
                 -- of
                 --   (a) local instance decls
-                --   (b) generic instances
-                --   (c) local family instance decls
+                --   (b) local family instance decls
        ; addInsts local_info         $
-         addInsts generic_inst_info  $
          addFamInsts at_idx_tycons   $ do {
 
-                -- (4) Compute instances from "deriving" clauses;
+                -- (3) Compute instances from "deriving" clauses;
                 -- This stuff computes a context for the derived instance
                 -- decl, so it needs to know about all the instances possible
                 -- NB: class instance declarations can contain derivings as
                 --     part of associated data type declarations
-        failIfErrsM            -- If the addInsts stuff gave any errors, don't
-                               -- try the deriving stuff, becuase that may give
-                               -- more errors still
-       ; (deriv_inst_info, deriv_binds, deriv_dus) 
+        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
-       ; gbl_env <- addInsts deriv_inst_info getGblEnv
+
+       -- Extend the global environment also with the generated datatypes for
+       -- the generic representation
+       ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $
+                      tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $
+                        addInsts deriv_inst_info getGblEnv
        ; return ( addTcgDUs gbl_env deriv_dus,
-                  generic_inst_info ++ deriv_inst_info ++ local_info,
+                  deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
     }}}
 
@@ -917,10 +917,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     ----------------------
     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+    tc_default sel_id (GenDefMeth dm_name)
+      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+           ; tc_body sel_id False {- Not generated code? -} meth_bind }
+{-
     tc_default sel_id GenDefMeth    -- Derivable type classes stuff
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
            ; tc_body sel_id False {- Not generated code? -} meth_bind }
-         
+-}
     tc_default sel_id NoDefMeth            -- No default method at all
       = do { warnMissingMethod sel_id
           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
index 23c2e67..4017167 100644 (file)
@@ -300,7 +300,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
        -- any mutually recursive types are done right
        -- Just discard the auxiliary bindings; they are generated 
        -- only for Haskell source code, and should already be in Core
-   (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+   (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ;
 
    setGblEnv tcg_env $ do {
        -- Make the new type env available to stuff slurped from interface files
@@ -501,7 +501,7 @@ tcRnHsBootDecls decls
 
                -- Typecheck type/class decls
        ; traceTc "Tc2" empty
-       ; (tcg_env, aux_binds, dm_ids) 
+       ; (tcg_env, aux_binds, dm_ids, _
                <- tcTyAndClassDecls emptyModDetails tycl_decls
        ; setGblEnv tcg_env    $ 
           tcExtendIdEnv dm_ids $ do {
@@ -848,7 +848,7 @@ tcTopSrcDecls boot_details
                -- The latter come in via tycl_decls
         traceTc "Tc2" empty ;
 
-       (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
+       (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ;
                -- If there are any errors, tcTyAndClassDecls fails here
        
        setGblEnv tcg_env       $
@@ -886,8 +886,9 @@ tcTopSrcDecls boot_details
         setLclTypeEnv tcl_env $ do {   -- Environment doesn't change now
 
                 -- Second pass over class and instance declarations, 
+                -- now using the kind-checked decls
         traceTc "Tc6" empty ;
-        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+        inst_binds <- tcInstDecls2 kc_decls inst_infos ;
 
                 -- Foreign exports
         traceTc "Tc7" empty ;
@@ -1586,7 +1587,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
          , ppr_fam_insts fam_insts
          , vcat (map ppr rules)
          , vcat (map ppr vects)
-         , ppr_gen_tycons (typeEnvTyCons type_env)
          , ptext (sLit "Dependent modules:") <+> 
                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
         , ptext (sLit "Dependent packages:") <+> 
@@ -1666,9 +1666,4 @@ ppr_rules [] = empty
 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
                      nest 2 (pprRules rs),
                      ptext (sLit "#-}")]
-
-ppr_gen_tycons :: [TyCon] -> SDoc
-ppr_gen_tycons []  = empty
-ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
-                          nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
 \end{code}
index a433d69..284972e 100644 (file)
@@ -25,12 +25,10 @@ import TcMType
 import TcType
 import TysWiredIn      ( unitTy )
 import Type
-import Generics
 import Class
 import TyCon
 import DataCon
 import Id
-import MkId            ( mkDefaultMethodId )
 import MkCore          ( rEC_SEL_ERROR_ID )
 import IdInfo
 import Var
@@ -61,12 +59,14 @@ import Data.List
 %************************************************************************
 
 \begin{code}
+
 tcTyAndClassDecls :: ModDetails 
                    -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
                   -> TcM (TcGblEnv,         -- Input env extended by types and classes 
                                             -- and their implicit Ids,DataCons
                           HsValBinds Name,  -- Renamed bindings for record selectors
-                          [Id])             -- Default method ids
+                          [Id],             -- Default method ids
+                           [LTyClDecl Name]) -- Kind-checked declarations
 -- Fails if there are any errors
 
 tcTyAndClassDecls boot_details decls_s
@@ -89,7 +89,7 @@ tcTyAndClassDecls boot_details decls_s
 
                       -- And now build the TyCons/Classes
                 ; let rec_flags = calcRecFlags boot_details rec_tyclss
-                 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+                ; concatMapM (tcTyClDecl rec_flags) kc_decls }
 
        ; tcExtendGlobalEnv tyclss $ do
        {  -- Perform the validity check
@@ -109,7 +109,10 @@ tcTyAndClassDecls boot_details decls_s
               ; dm_ids          = mkDefaultMethodIds tyclss }
 
        ; env <- tcExtendGlobalEnv implicit_things getGblEnv
-       ; return (env, rec_sel_binds, dm_ids) } }
+          -- We need the kind-checked declarations later, so we return them
+          -- from here
+        ; kc_decls <- kcTyClDecls tyclds_s
+        ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
                     
 zipRecTyClss :: [[LTyClDecl Name]]
              -> [TyThing]           -- Knot-tied
@@ -268,7 +271,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                   NewType  -> ASSERT( not (null data_cons) )
                               mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                            False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+                            h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -488,6 +491,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   where
     kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
                                   ; return (TypeSig nm op_ty') }
+    kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+                                     ; return (GenericSig nm op_ty') }
     kc_sig other_sig         = return other_sig
 
 kcTyClDecl decl@(ForeignType {})
@@ -634,7 +639,7 @@ tcTyClDecl1 parent _calc_isrec
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-               DataFamilyTyCon Recursive False True 
+               DataFamilyTyCon Recursive True 
                parent Nothing
   ; return [ATyCon tycon]
   }
@@ -660,7 +665,6 @@ tcTyClDecl1 _parent calc_isrec
   { extra_tvs <- tcDataKindSig mb_ksig
   ; let final_tvs = tvs' ++ extra_tvs
   ; stupid_theta <- tcHsKindedContext ctxt
-  ; want_generic <- xoptM Opt_Generics
   ; unbox_strict <- doptM Opt_UnboxStrictFields
   ; empty_data_decls <- xoptM Opt_EmptyDataDecls
   ; kind_signatures <- xoptM Opt_KindSignatures
@@ -702,8 +706,7 @@ tcTyClDecl1 _parent calc_isrec
                   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
        ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-           (want_generic && canDoGenerics data_cons) (not h98_syntax) 
-            NoParentTyCon Nothing
+           (not h98_syntax) NoParentTyCon Nothing
        })
   ; return [ATyCon tycon]
   }
@@ -1134,9 +1137,9 @@ checkValidClass cls
   where
     (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
     unary      = isSingleton tyvars
-    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+    no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
-    check_op constrained_class_methods (sel_id, dm
+    check_op constrained_class_methods (sel_id, _
       = addErrCtxt (classOpCtxt sel_id tau) $ do
        { checkValidTheta SigmaCtxt (tail theta)
                -- The 'tail' removes the initial (C a) from the
@@ -1157,8 +1160,10 @@ checkValidClass cls
 
                -- Check that for a generic method, the type of 
                -- the method is sufficiently simple
+{- -- JPM TODO  (when reinstating, remove commenting-out of badGenericMethodType
        ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
                  (badGenericMethodType op_name op_ty)
+-}
        }
        where
          op_name = idName sel_id
@@ -1186,7 +1191,7 @@ checkValidClass cls
 mkDefaultMethodIds :: [TyThing] -> [Id]
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds things
-  = [ mkDefaultMethodId sel_id dm_name
+  = [ mkExportedLocalId dm_name (idType sel_id)
     | AClass cls <- things
     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
 \end{code}
@@ -1424,11 +1429,13 @@ genericMultiParamErr clas
   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> 
     ptext (sLit "cannot have generic methods")
 
+{-  Commented out until the call is reinstated
 badGenericMethodType :: Name -> Kind -> SDoc
 badGenericMethodType op op_ty
   = hang (ptext (sLit "Generic method type is too complex"))
        2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
                ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
+-}
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls
index 1e16bc4..d9e44e5 100644 (file)
@@ -81,7 +81,7 @@ type ClassOpItem = (Id, DefMeth)
 
 data DefMeth = NoDefMeth               -- No default method
             | DefMeth Name             -- A polymorphic default method
-            | GenDefMeth               -- A generic default method
+            | GenDefMeth Name          -- A generic default method
              deriving Eq  
 
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
@@ -91,7 +91,7 @@ defMethSpecOfDefMeth meth
  = case meth of
        NoDefMeth       -> NoDM
        DefMeth _       -> VanillaDM
-       GenDefMeth      -> GenericDM
+       GenDefMeth _    -> GenericDM
 
 \end{code}
 
@@ -208,9 +208,9 @@ instance Show Class where
     showsPrec p c = showsPrecSDoc p (ppr c)
 
 instance Outputable DefMeth where
-    ppr (DefMeth n) =  ptext (sLit "Default method") <+> ppr n
-    ppr GenDefMeth  =  ptext (sLit "Generic default method")
-    ppr NoDefMeth   =  empty   -- No default method
+    ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
+    ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
+    ppr NoDefMeth      =  empty   -- No default method
 
 pprFundeps :: Outputable a => [FunDep a] -> SDoc
 pprFundeps []  = empty
index 604db8d..6aebe4c 100644 (file)
@@ -1,18 +1,12 @@
 %
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2011
 %
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module Generics ( canDoGenerics, mkTyConGenericBinds,
-                 mkGenericRhs, 
-                 validGenericInstanceType, validGenericMethodType
+
+module Generics ( canDoGenerics,
+                 mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+                 MetaTyCons(..), metaTyCons2TyCons
     ) where
 
 
@@ -22,17 +16,18 @@ import TcType
 import DataCon
 
 import TyCon
-import Name
+import Name hiding (varName)
+import Module (moduleName, moduleNameString)
 import RdrName
 import BasicTypes
-import Var
-import VarSet
-import Id
 import TysWiredIn
 import PrelNames
-       
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad (TcM, newUnique)
+import HscTypes
+
 import SrcLoc
-import Util
 import Bag
 import Outputable 
 import FastString
@@ -40,185 +35,6 @@ import FastString
 #include "HsVersions.h"
 \end{code}
 
-Roadmap of what's where in the Generics work.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Parser
-No real checks.
-
-RnSource.rnHsType
-  Checks that HsNumTy has a "1" in it.
-
-TcInstDcls.mkGenericInstance:
-  Checks for invalid type patterns, such as f {| Int |}
-
-TcClassDcl.tcClassSig
-  Checks for a method type that is too complicated;
-       e.g. has for-alls or lists in it
-  We could lift this restriction
-
-TcClassDecl.mkDefMethRhs
-  Checks that the instance type is simple, in an instance decl 
-  where we let the compiler fill in a generic method.
-       e.g.  instance C (T Int)
-       is not valid if C has generic methods.
-
-TcClassDecl.checkGenericClassIsUnary
-  Checks that we don't have generic methods in a multi-parameter class
-
-TcClassDecl.checkDefaultBinds
-  Checks that all the equations for a method in a class decl
-  are generic, or all are non-generic
-
-
-                       
-Checking that the type constructors which are present in Generic
-patterns (not Unit, this is done differently) is done in mk_inst_info
-(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
-HsOpTy is tied to Generic definitions which is not a very good design
-feature, indeed a bug. However, the check is easy to move from
-tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5. [I don't think that this is the case anymore after SPJ's latest
-changes in that regard.  Delete this comment?  -=chak/7Jun2]
-
-Generics.lhs
-
-Making generic information to put into a tycon. Constructs the
-representation type, which, I think, are not used later. Perhaps it is
-worth removing them from the GI datatype. Although it does get used in
-the construction of conversion functions (internally).
-
-TyCon.lhs
-
-Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
-
-TysWiredIn.lhs
-
-Defines generic and other type and data constructors.
-
-This is sadly incomplete, but will be added to.
-
-
-Bugs & shortcomings of existing implementation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-2. Another pretty big bug I dscovered at the last minute when I was
-testing the code is that at the moment the type variable of the class
-is scoped over the entire declaration, including the patterns. For
-instance, if I have the following code,
-
-class Er a where
- ...
-  er {| Plus a b |} (Inl x) (Inl y) = er x y 
-  er {| Plus a b |} (Inr x) (Inr y) = er x y 
-  er {| Plus a b |} _ _ = False
-and I print out the types of the generic patterns, I get the
-following.  Note that all the variable names for "a" are the same,
-while for "b" they are all different.
-
-check_ty
-    [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
-     std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
-     std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
-
-This is a bug as if I change the code to
-
- er {| Plus c b |} (Inl x)  (Inl y) = er x y 
-
-all the names come out to be different.
-
-Thus, all the types (Plus a b) come out to be different, so I cannot
-compare them and test whether they are all the same and thus cannot
-return an error if the type variables are different.
-
-Temporary fix/hack. I am not checking for this, I just assume they are
-the same, see line "check_ty = True" in TcInstDecls. When we resolve
-the issue with variables, though - I assume that we will make them to
-be the same in all the type patterns, jus uncomment the check and
-everything should work smoothly.
-
-Hence, I have also left the rather silly construction of:
-* extracting all the type variables from all the types
-* putting them *all* into the environment
-* typechecking all the types
-* selecting one of them and using it as the instance_ty.
-
-(the alternative is to make sure that all the types are the same,
-taking one, extracting its variables, putting them into the environment,
-type checking it, using it as the instance_ty)
-6. What happens if we do not supply all of the generic patterns? At
-the moment, the compiler crashes with an error message "Non-exhaustive
-patterns in a generic declaration" 
-
-
-What has not been addressed:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Contexts. In the generated instance declarations for the 3 primitive
-type constructors, we need contexts. It is unclear what those should
-be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
-
-Type application. We have type application in expressions
-(essentially) on the lhs of an equation. Do we want to allow it on the
-RHS?
-
-Scoping of type variables in a generic definition. At the moment, (see
-TcInstDecls) we extract the type variables inside the type patterns
-and add them to the environment. See my bug #2 above. This seems pretty
-important.
-
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Getting the representation type out}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-validGenericInstanceType :: Type -> Bool
-  -- Checks for validity of the type pattern in a generic
-  -- declaration.  It's ok to have  
-  --   f {| a + b |} ...
-  -- but it's not OK to have
-  --   f {| a + Int |}
-
-validGenericInstanceType inst_ty
-  = case tcSplitTyConApp_maybe inst_ty of
-       Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
-       Nothing           ->  False
-
-validGenericMethodType :: Type -> Bool
-  -- At the moment we only allow method types built from
-  --   * type variables
-  --   * function arrow
-  --   * boxed tuples
-  --    * lists
-  --   * an arbitrary type not involving the class type variables
-  --           e.g. this is ok:        forall b. Ord b => [b] -> a
-  --                where a is the class variable
-validGenericMethodType ty 
-  = valid tau
-  where
-    (local_tvs, _, tau) = tcSplitSigmaTy ty
-
-    valid ty
-      | not (isTauTy ty) = False       -- Note [Higher ramk methods]
-      | isTyVarTy ty     = True
-      | no_tyvars_in_ty         = True
-      | otherwise       = case tcSplitTyConApp_maybe ty of
-                               Just (tc,tys) -> valid_tycon tc && all valid tys
-                               Nothing       -> False
-      where
-       no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-
-    valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc 
-       -- Compare bimapApp, below
-\end{code}
-
-
 %************************************************************************
 %*                                                                     *
 \subsection{Generating representation types}
@@ -226,14 +42,24 @@ validGenericMethodType ty
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: TyCon -> Bool
 -- Called on source-code data types, to see if we should generate
--- generic functions for them.  (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics data_cons
-  =  not (any bad_con data_cons)       -- See comment below
-  && not (null data_cons)              -- No values of the type
+-- generic functions for them.
+
+canDoGenerics tycon
+  =  let result = not (any bad_con (tyConDataCons tycon))      -- See comment below
+                  -- We do not support datatypes with context (for now)
+                  && null (tyConStupidTheta tycon)
+{-
+                  -- Primitives are (probably) not representable either
+                  && not (isPrimTyCon tycon)
+                  -- Foreigns are (probably) not representable either
+                  && not (isForeignTyCon tycon)
+-}
+                  -- We don't like type families
+                  && not (isFamilyTyCon tycon)
+
+     in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result
   where
     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
        -- If any of the constructor has an unboxed type as argument,
@@ -255,320 +81,299 @@ canDoGenerics data_cons
 
 \begin{code}
 type US = Int  -- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
-
-mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon
-  = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
-       `unionBags`
-    unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+type Alt = (LPat RdrName, LHsExpr RdrName)
+
+-- Bindings for the Representable0 instance
+mkBindsRep0 :: TyCon -> LHsBinds RdrName
+mkBindsRep0 tycon = 
+    unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
+  `unionBags`
+    unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
+      where
+        from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
+        to0_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts  ]
+        loc           = srcLocSpan (getSrcLoc tycon)
+        datacons      = tyConDataCons tycon
+
+        -- Recurse over the sum first
+        from0_alts, to0_alts :: [Alt]
+        (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
+        
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRep0Ty :: -- The type to generate representation for
+               TyCon 
+               -- Metadata datatypes to refer to
+            -> MetaTyCons 
+               -- Generated representation0 type
+            -> TcM Type
+tc_mkRep0Ty tycon metaDts = 
+  do
+    d1 <- tcLookupTyCon d1TyConName
+    c1 <- tcLookupTyCon c1TyConName
+    s1 <- tcLookupTyCon s1TyConName
+    rec0 <- tcLookupTyCon rec0TyConName
+    par0 <- tcLookupTyCon par0TyConName
+    u1 <- tcLookupTyCon u1TyConName
+    v1 <- tcLookupTyCon v1TyConName
+    plus <- tcLookupTyCon sumTyConName
+    times <- tcLookupTyCon prodTyConName
+    
+    let mkSum' a b = mkTyConApp plus  [a,b]
+        mkProd a b = mkTyConApp times [a,b]
+        mkRec0 a   = mkTyConApp rec0  [a]
+        mkPar0 a   = mkTyConApp par0  [a]
+        mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a)]
+        mkS    d a = mkTyConApp s1    [d, a]
+        
+        sumP [] = mkTyConTy v1
+        sumP l  = ASSERT (length metaCTyCons == length l)
+                    foldBal mkSum' [ mkC i d a
+                                   | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+        prod :: Int -> [Type] -> Type
+        prod i [] = ASSERT (length metaSTyCons > i)
+                      ASSERT (length (metaSTyCons !! i) == 0)
+                        mkTyConTy u1
+        prod i l  = ASSERT (length metaSTyCons > i)
+                      ASSERT (length l == length (metaSTyCons !! i))
+                        foldBal mkProd [ arg d a 
+                                       | (d,a) <- zip (metaSTyCons !! i) l ]
+        
+        arg d t = mkS 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
+        
+        metaDTyCon  = mkTyConTy (metaD metaDts)
+        metaCTyCons = map mkTyConTy (metaC metaDts)
+        metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+        
+    return (mkD tycon)
+
+tc_mkRep0TyCon :: TyCon           -- The type to generate representation for
+               -> MetaTyCons      -- Metadata datatypes to refer to
+               -> TcM TyCon       -- Generated representation0 type
+tc_mkRep0TyCon tycon metaDts = 
+-- Consider the example input tycon `D`, where data D a b = D_ a
+  do
+    uniq1   <- newUnique
+    uniq2   <- newUnique
+    -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+    rep0Ty  <- tc_mkRep0Ty tycon metaDts
+    -- `rep0` = GHC.Generics.Rep0 (type family)
+    rep0    <- tcLookupTyCon rep0TyConName
+    
+    let modl    = nameModule  (tyConName tycon)
+        loc     = nameSrcSpan (tyConName tycon)
+        -- `repName` is a name we generate for the synonym
+        repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
+        -- `coName` is a name for the coercion
+        coName  = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
+        -- `tyvars` = [a,b]
+        tyvars  = tyConTyVars tycon
+        -- `appT` = D a b
+        appT    = [mkTyConApp tycon (mkTyVarTys tyvars)]
+        -- Result
+        res = mkSynTyCon repName
+                 -- rep0Ty has kind `kind of D` -> *
+                 (tyConKind tycon `mkArrowKind` liftedTypeKind)
+                 tyvars (SynonymTyCon rep0Ty)
+                 (FamInstTyCon rep0 appT
+                   (mkCoercionTyCon coName (tyConArity tycon)
+                     -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
+                     (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
+
+    return res
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+                               metaD :: TyCon
+                               -- One meta datatype per constructor
+                             , metaC :: [TyCon]
+                               -- One meta datatype per selector per constructor
+                             , metaS :: [[TyCon]] }
+                             
+instance Outputable MetaTyCons where
+  ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+                                   
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon 
+             -> ( LHsBinds RdrName      -- Datatype instance
+                , [LHsBinds RdrName]    -- Constructor instances
+                , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+      where
+        mkBag l = foldr1 unionBags 
+                    [ unitBag (L loc (mkFunBind (L loc name) matches)) 
+                        | (name, matches) <- l ]
+        dtBinds       = mkBag [ (datatypeName_RDR, dtName_matches)
+                              , (moduleName_RDR, moduleName_matches)]
+
+        allConBinds   = map conBinds datacons
+        conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
+                              ++ ifElseEmpty (dataConIsInfix c)
+                                   [ (conFixity_RDR, conFixity_matches c) ]
+                              ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+                                   [ (conIsRecord_RDR, conIsRecord_matches c) ]
+                              )
+
+        ifElseEmpty p x = if p then x else []
+        fixity c      = case lookupFixity fix_env (dataConName c) of
+                          Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+                          Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+                          Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+        buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+                                                     , nlHsIntLit (toInteger n)]
+
+        allSelBinds   = map (map selBinds) datasels
+        selBinds s    = mkBag [(selName_RDR, selName_matches s)]
+
+        loc           = srcLocSpan (getSrcLoc tycon)
+        mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+        datacons      = tyConDataCons tycon
+        datasels      = map dataConFieldLabels datacons
+
+        dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName 
+                           $ tycon
+        moduleName_matches = mkStringLHS . moduleNameString . moduleName 
+                           . nameModule . tyConName $ tycon
+
+        conName_matches     c = mkStringLHS . showPpr . nameOccName
+                              . dataConName $ c
+        conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
+        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+        selName_matches     s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: US          -- Base for generating unique names
+      -> TyCon       -- The type constructor
+      -> [DataCon]   -- The data constructors
+      -> ([Alt],     -- Alternatives for the T->Trep "from" function
+          [Alt])     -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _us 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 tycon
+    errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+  unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: 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)
   where
-    from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
-    to_matches   = [mkSimpleHsAlt to_pat to_body]
-    loc             = srcLocSpan (getSrcLoc tycon)
-    datacons = tyConDataCons tycon
-    (from_RDR, to_RDR) = mkGenericNames tycon
-
-    -- Recurse over the sum first
-    from_alts :: [FromAlt]
-    (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
-    init_us = 1::Int           -- Unique supply
-
-----------------------------------------------------
---     Dealing with sums
-----------------------------------------------------
-
-mk_sum_stuff :: US                     -- Base for generating unique names
-            -> [DataCon]               -- The data constructors
-            -> ([FromAlt],                             -- Alternatives for the T->Trep "from" function
-                InPat RdrName, LHsExpr RdrName)        -- Arg and body of the Trep->T "to" function
-
--- For example, given
---     data T = C | D Int Int Int
--- 
--- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
---                        case cd of { Inl u -> C; 
---                                     Inr abc -> case abc of { a :*: bc ->
---                                                case bc  of { b :*: c ->
---                                                D a b c }} },
---                        cd)
-
-mk_sum_stuff us [datacon]
-   = ([from_alt], to_pat, to_body_fn app_exp)
-   where
-     n_args = dataConSourceArity datacon       -- Existentials already excluded
-
-     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
-     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, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
-
-mk_sum_stuff us datacons
-  = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
-     nlVarPat to_arg,
-     noLoc (HsCase (nlHsVar to_arg) 
-           (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
-                          mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
+    n_args = dataConSourceArity datacon        -- Existentials already excluded
+
+    datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+    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))
+    
+    to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+                 -- These M1s are meta-information for the datatype
+    to_alt_rhs = app_exp
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
+genLR_P i n p
+  | n == 0       = error "impossible"
+  | n == 1       = p
+  | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+                     where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
+genLR_E i n e
+  | n == 0       = error "impossible"
+  | n == 1       = e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
+                     where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: US             -- Base for unique names
+        -> [RdrName]       -- List of variables matched on the lhs
+        -> 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
   where
-    (l_datacons, r_datacons)           = splitInHalf datacons
-    (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
-    (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
-
-    to_arg = mkGenericLocal us
-    us'           = us+1
-
-    wrap :: RdrName -> [FromAlt] -> [FromAlt]
-       -- Wrap an application of the Inl or Inr constructor round each alternative
-    wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
-
-
-----------------------------------------------------
---     Dealing with products
-----------------------------------------------------
-mk_prod_stuff :: US                    -- Base for unique names
-             -> [RdrName]              -- arg-ids; args of the original user-defined constructor
-                                       --      They are bound enclosing from_rhs
-                                       --      Please bind these in the to_body_fn 
-             -> (US,                   -- Depleted unique-name supply
-                 LHsExpr RdrName,                      -- from-rhs: puts together the representation from the arg_ids
-                 InPat RdrName,                        -- to_pat: 
-                 LHsExpr RdrName -> LHsExpr RdrName)   -- to_body_fn: takes apart the representation
-
--- For example:
--- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
---                              abc,
---                              \<body-code> -> case abc of { a :*: bc ->
---                                              case bc  of { b :*: c  -> 
---                                              <body-code> )
-
--- We need to use different uniques in the branches 
--- because the returned to_body_fns are nested.  
--- Hence the returned unqique-name supply
-
-mk_prod_stuff us []            -- Unit case
-  = (us+1,
-     nlHsVar genUnitDataCon_RDR,
-     noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) 
-                    (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
-       -- Give a signature to the pattern so we get 
-       --      data S a = Nil | S a
-       --      toS = \x -> case x of { Inl (g :: Unit) -> Nil
-       --                              Inr x -> S x }
-       -- The (:: Unit) signature ensures that we'll infer the right
-       -- type for toS. If we leave it out, the type is too polymorphic
-
-     \x -> x)
-
-mk_prod_stuff us [arg_var]     -- Singleton case
-  = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
-
-mk_prod_stuff us arg_vars      -- Two or more
-  = (us'', 
-     nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
-     nlVarPat to_arg, 
--- gaw 2004 FIX?
-     \x -> noLoc (HsCase (nlHsVar to_arg) 
-                 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
+    appVars = map wrapArg_E vars
+    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
+
+-- Build a product pattern
+mkProd_P :: 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
   where
-    to_arg = mkGenericLocal us
-    (l_arg_vars, r_arg_vars)                 = splitInHalf arg_vars
-    (us',  l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
-    (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
-    pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
-
-splitInHalf :: [a] -> ([a],[a])
-splitInHalf list = (left, right)
-                where
-                  half  = length list `div` 2
-                  left  = take half list
-                  right = drop half list
+    appVars = map wrapArg_P 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
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 
-mkGenericNames :: TyCon -> (RdrName, RdrName)
-mkGenericNames tycon
-  = (from_RDR, to_RDR)
-  where
-    tc_name  = tyConName tycon
-    tc_occ   = nameOccName tc_name
-    tc_mod   = ASSERT( isExternalName tc_name ) nameModule tc_name
-    from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
-    to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection{Generating the RHS of a generic default method}
-%*                                                                     *
-%************************************************************************
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 
-Generating the Generic default method.  Uses the bimaps to generate the
-actual method. All of this is rather incomplete, but it would be nice
-to make even this work.  Example
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
 
-       class Foo a where
-         op :: Op a
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
 
-       instance Foo T
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _  x []  = x
+foldBal' _  _ [y] = y
+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
+                    in foldBal' op x a `op` foldBal' op x b
 
-Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
-
-       instance Foo T where
-          op = <mkGenericRhs op a T>
-
-To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
-
-       toOp   :: Op Trep -> Op T
-       fromOp :: Op T    -> Op Trep
-
-(the bimap) and then fill in the RHS with
-
-       instance Foo T where
-          op = toOp op
-
-Remember, we're generating a RenamedHsExpr, so the result of all this
-will be fed to the type checker.  So the 'op' on the RHS will be 
-at the representation type for T, Trep.
-
-
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the class op is polymorphic:
-
-       class Baz a where
-         op :: forall b. Ord b => a -> b -> b
-
-Then we can still generate a bimap with
-
-       toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
-
-and fill in the instance decl thus
-
-       instance Foo T where
-          op = toOp op
-
-By the time the type checker has done its stuff we'll get
-
-       instance Foo T where
-          op = \b. \dict::Ord b. toOp b (op Trep b dict)
-
-Note [Higher rank methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Higher-rank method types don't work, because we'd generate a bimap that
-needs impredicative polymorphism.  In principle that should be possible
-(with boxy types and all) but it would take a bit of working out.   Here's
-an example:
-  class ChurchEncode k where 
-    match :: k -> z 
-                 -> (forall a b z. a -> b -> z)  {- product -} 
-                 -> (forall a   z. a -> z)       {- left -} 
-                 -> (forall a   z. a -> z)       {- right -} 
-                 -> z 
-  
-    match {| Unit    |} Unit      unit prod left right = unit 
-    match {| a :*: b |} (x :*: y) unit prod left right = prod x y 
-    match {| a :+: b |} (Inl l)   unit prod left right = left l 
-    match {| a :+: b |} (Inr r)   unit prod left right = right r 
-
-\begin{code}
-mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
-mkGenericRhs sel_id tyvar tycon
-  = ASSERT( isSingleton ctxt )         -- Checks shape of selector-id context
---    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
-    mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
-  where 
-       -- Initialising the "Environment" with the from/to functions
-       -- on the datatype (actually tycon) in question
-       (from_RDR, to_RDR) = mkGenericNames tycon 
-
-        -- Instantiate the selector type, and strip off its class context
-       (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
-
-        -- Do it again!  This deals with the case where the method type 
-       -- is polymorphic -- see Note [Polymorphic methods] above
-       (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-
-       -- Now we probably have a tycon in front
-        -- of us, quite probably a FunTyCon.
-        ep    = EP (nlHsVar from_RDR) (nlHsVar to_RDR) 
-        bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
-
-type EPEnv = (TyVar,                   -- The class type variable
-             EP (LHsExpr RdrName),     -- The EP it maps to
-             [TyVar]                   -- Other in-scope tyvars; they have an identity EP
-            )
-
--------------------
-generate_bimap :: EPEnv
-              -> Type
-              -> EP (LHsExpr RdrName)
--- Top level case - splitting the TyCon.
-generate_bimap env@(tv,ep,local_tvs) ty 
-  | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-  = idEP       -- A constant type
-
-  | Just tv1 <- getTyVar_maybe ty
-  = ASSERT( tv == tv1 ) ep                                     -- The class tyvar
-
-  | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
-  = bimapTyCon tycon (map (generate_bimap env) ty_args)
-
-  | otherwise
-  = pprPanic "generate_bimap" (ppr ty)
-
--------------------
-bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTyCon tycon arg_eps 
-  | tycon == funTyCon       = bimapArrow arg_eps
-  | tycon == listTyCon      = bimapList arg_eps
-  | isBoxedTupleTyCon tycon = bimapTuple arg_eps
-  | otherwise              = pprPanic "bimapTyCon" (ppr tycon)
-
--------------------
--- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
-bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapArrow [ep1, ep2]
-  = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, 
-        toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
-  where
-    from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
-    to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
-
--------------------
--- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
-bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTuple eps 
-  = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
-        toEP   = mkHsLam [noLoc tuple_pat] to_body }
-  where
-    names      = takeList eps gs_RDR
-    tuple_pat  = TuplePat (map nlVarPat names) Boxed placeHolderType
-    eps_w_names = eps `zip` names
-    to_body     = mkLHsTupleExpr [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-    from_body   = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-
--------------------
--- bimapList :: EP a b -> EP [a] [b]
-bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapList [ep]
-  = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
-        toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
-
--------------------
-a_RDR, b_RDR :: RdrName
-a_RDR  = mkVarUnqual (fsLit "a")
-b_RDR  = mkVarUnqual (fsLit "b")
-
-gs_RDR :: [RdrName]
-gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
-
-idEP :: EP (LHsExpr RdrName)
-idEP = EP idexpr idexpr
-     where
-       idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
 \end{code}
index adb0470..5804d49 100644 (file)
@@ -49,7 +49,7 @@ module TyCon(
        isTyConAssoc,
        isRecursiveTyCon,
        isHiBootTyCon,
-        isImplicitTyCon, tyConHasGenerics,
+        isImplicitTyCon, 
 
         -- ** Extracting information out of TyCons
        tyConName,
@@ -67,7 +67,7 @@ module TyCon(
        tyConExtName,           -- External name for foreign types
        algTyConRhs,
         newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, 
-        tupleTyConBoxity,
+        tupleTyConBoxity, tupleTyConArity,
 
         -- ** Manipulating TyCons
        tcExpandTyCon_maybe, coreExpandTyCon_maybe,
@@ -317,11 +317,7 @@ data TyCon
 
        algTcRec :: RecFlag,      -- ^ Tells us whether the data type is part 
                                   -- of a mutually-recursive group or not
-
-       hasGenerics :: Bool,      -- ^ Whether generic (in the -XGenerics sense) 
-                                  -- to\/from functions are available in the exports 
-                                  -- of the data type's source module.
-
+       
        algTcParent :: TyConParent      -- ^ Gives the class or family declaration 'TyCon' 
                                         -- for derived 'TyCon's representing class 
                                         -- or family instances, respectively. 
@@ -337,8 +333,7 @@ data TyCon
        tyConArity  :: Arity,
        tyConBoxed  :: Boxity,
        tyConTyVars :: [TyVar],
-       dataCon     :: DataCon, -- ^ Corresponding tuple data constructor
-       hasGenerics :: Bool
+       dataCon     :: DataCon -- ^ Corresponding tuple data constructor
     }
 
   -- | Represents type synonyms
@@ -776,10 +771,9 @@ mkAlgTyCon :: Name
            -> AlgTyConRhs       -- ^ Information about dat aconstructors
            -> TyConParent
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
-           -> Bool              -- ^ Does it have generic functions? See 'hasGenerics'
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
            -> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
   = AlgTyCon { 
        tyConName        = name,
        tyConUnique      = nameUnique name,
@@ -790,14 +784,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
        algTcRhs         = rhs,
        algTcParent      = ASSERT( okParent name parent ) parent,
        algTcRec         = is_rec,
-       algTcGadtSyntax  = gadt_syn,
-       hasGenerics      = gen_info
+       algTcGadtSyntax  = gadt_syn
     }
 
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
 mkClassTyCon name kind tyvars rhs clas is_rec =
-  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
+  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
 
 mkTupleTyCon :: Name 
              -> Kind    -- ^ Kind of the resulting 'TyCon'
@@ -805,9 +798,8 @@ mkTupleTyCon :: Name
              -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
              -> DataCon 
              -> Boxity  -- ^ Whether the tuple is boxed or unboxed
-             -> Bool    -- ^ Does it have generic functions? See 'hasGenerics'
              -> TyCon
-mkTupleTyCon name kind arity tyvars con boxed gen_info
+mkTupleTyCon name kind arity tyvars con boxed 
   = TupleTyCon {
        tyConUnique = nameUnique name,
        tyConName = name,
@@ -815,8 +807,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info
        tyConArity = arity,
        tyConBoxed = boxed,
        tyConTyVars = tyvars,
-       dataCon = con,
-       hasGenerics = gen_info
+       dataCon = con
     }
 
 -- ^ Foreign-imported (.NET) type constructors are represented
@@ -1087,6 +1078,11 @@ isBoxedTupleTyCon _                                  = False
 tupleTyConBoxity :: TyCon -> Boxity
 tupleTyConBoxity tc = tyConBoxed tc
 
+-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
+-- Panics otherwise
+tupleTyConArity :: TyCon -> Arity
+tupleTyConArity tc = tyConArity tc
+
 -- | Is this a recursive 'TyCon'?
 isRecursiveTyCon :: TyCon -> Bool
 isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
@@ -1195,11 +1191,6 @@ expand tvs rhs tys
 \end{code}
 
 \begin{code}
--- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics'
-tyConHasGenerics :: TyCon -> Bool
-tyConHasGenerics (AlgTyCon {hasGenerics = hg})   = hg
-tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics _                               = False        -- Synonyms
 
 tyConKind :: TyCon -> Kind
 tyConKind (FunTyCon   { tc_kind = k }) = k
index 5f348ef..c9bf3f5 100644 (file)
@@ -949,9 +949,9 @@ isAlgType ty
 isClosedAlgType :: Type -> Bool
 isClosedAlgType ty
   = case splitTyConApp_maybe ty of
-      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
-                           isAlgTyCon tc && not (isFamilyTyCon tc)
-      _other            -> False
+      Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
 \end{code}
 
 \begin{code}
index 332344b..b7bd95e 100644 (file)
@@ -31,7 +31,6 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
                            []          -- no stupid theta
                            rhs
                            rec_flag    -- FIXME: is this ok?
-                           False       -- FIXME: no generics
                            False       -- not GADT syntax
                            NoParentTyCon
                            (Just $ mk_fam_inst pdata vect_tc)
index 0fa8482..cbfea45 100644 (file)
@@ -82,7 +82,6 @@ vectTyConDecl tycon
                             []                  -- no stupid theta.
                             rhs'                -- new constructor defs.
                             rec_flag            -- FIXME: is this ok?
-                            False               -- FIXME: no generics
                             False               -- not GADT syntax
                             NoParentTyCon
                             Nothing             -- not a family instance