Initial commit for Pedro's new generic default methods
authorsimonpj <simonpj@cam-04-unx.europe.corp.microsoft.com>
Tue, 12 Apr 2011 15:39:18 +0000 (16:39 +0100)
committersimonpj <simonpj@cam-04-unx.europe.corp.microsoft.com>
Tue, 12 Apr 2011 15:39:18 +0000 (16:39 +0100)
(See his Haskell Symposium 2010 paper
    "A generic deriving mechaism for Haskell")

24 files changed:
compiler/basicTypes/OccName.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/MkIface.lhs
compiler/main/HscStats.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.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

index f02ae8d..238c091 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, mkGenC, mkGenS, mkGenR0, mkGenR0Co,
        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
        mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
        mkInstTyCoOcc, mkEqPredCoOcc,
@@ -540,9 +541,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,
@@ -554,6 +556,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
@@ -572,10 +575,19 @@ 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 occ m   = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+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 e080bee..f1cdebb 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
 
 sigForThisGroup :: NameSet -> LSig Name -> Bool
 sigForThisGroup ns sig
@@ -706,9 +712,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
@@ -731,6 +738,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")
@@ -745,6 +753,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 
@@ -758,6 +767,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 bf75f4c..4fbd13a 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 e71eefe..805fcd7 100644 (file)
@@ -229,8 +229,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 +333,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 b940cb1..8590b5c 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)
 
index b96eb56..a618cbc 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) 
index 5c41d72..26f7e48 100644 (file)
@@ -431,6 +431,7 @@ data Token
   | ITderiving
   | ITdo
   | ITelse
+  | ITgeneric
   | IThiding
   | ITif
   | ITimport
@@ -635,6 +636,7 @@ reservedWordsFM = listToUFM $
        ( "deriving",   ITderiving,     0 ), 
        ( "do",         ITdo,           0 ),       
        ( "else",       ITelse,         0 ),     
+       ( "generic",    ITgeneric,      bit genericsBit ),     
        ( "hiding",     IThiding,       0 ),
        ( "if",         ITif,           0 ),       
        ( "import",     ITimport,       0 ),   
@@ -1752,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 -- integer
 
 genericsBit :: Int
-genericsBit = 0 -- {| and |}
+genericsBit = 0 -- {|, |} and "generic"
 ffiBit :: Int
 ffiBit    = 1
 parrBit :: Int
index bfadfba..078cfa4 100644 (file)
@@ -216,6 +216,7 @@ incorrect.
  'deriving'    { L _ ITderiving }
  'do'          { L _ ITdo }
  'else'        { L _ ITelse }
+ 'generic'     { L _ ITgeneric }
  'hiding'      { L _ IThiding }
  'if'          { L _ ITif }
  'import'      { L _ ITimport }
@@ -1232,9 +1233,13 @@ 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
+        : 'generic' infixexp '::' sigtypedoc
+                        {% do (TypeSig l ty) <- checkValSig $2 $4
+                        ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) }
+       -- 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..052b9a6 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 s _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
+    generic_RDR = mkUnqual varName (fsLit "generic")
 
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool
index 24756d5..08d99dc 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,61 @@ 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, conIsTuple_RDR,
+  noArityDataCon_RDR, arityDataCon_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")
+conIsTuple_RDR    = varQual_RDR gHC_GENERICS (fsLit "conIsTuple")
+
+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 +640,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 +854,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 +1053,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 +1147,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 +1204,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 0b10764..03dfa08 100644 (file)
@@ -586,8 +586,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) }
@@ -663,7 +675,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'
@@ -690,6 +707,11 @@ 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 { 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) }
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 725baeb..e359127 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..62a3da8 100644 (file)
@@ -97,48 +97,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
-
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+  = 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 ]
 
+       ; sequence [ failWithTc (badMethodErr clas n)
+                  | n <- dm_bind_names, not (n `elem` op_names) ]
+                 -- Value binding for non class-method (ie no TypeSig)
 
-tcClassSig :: NameEnv DefMethSpec      -- Info about default methods; 
-          -> LSig Name
-          -> TcM TcMethInfo
+       ; sequence [ failWithTc (badGenericMethod clas n)
+                  | n <- genop_names, not (n `elem` dm_bind_names) ]
+                 -- Generic signature without value binding
 
-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 +162,76 @@ 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)
-  = 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 }
+tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+  | NoDefMeth <- dm_info = return emptyBag
+  | otherwise
+  = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info 
+       ; let L loc meth_bind = findMethodBind sel_name binds_in
+                               `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+              dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) })
+                             -- Substitute the meth_name for the binder
+                            -- NB: the binding is always a FunBind
+
+             dm_sig_fn  _  = Just (clas_tv_names ++ tvs, sig_loc)
+              dm_prag_fn _  = prag_fn sel_name
+
+       ; (binds,_) <- tcExtendIdEnv [dm_id] $
+                      tcPolyBinds TopLevel dm_sig_fn dm_prag_fn 
+                            NonRecursive NonRecursive
+                            [dm_bind]
+        ; return binds }
+  where
+    sel_name      = idName sel_id
+    clas_tv_names = map getName tyvars
+
+    -- Find the 'generic op :: ty' signature among the sigs
+    -- If dm_info is GenDefMeth, the corresponding signature
+    -- should jolly well exist!  Hence the panic
+    genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+                             , n == sel_name ] of
+                      [lty] -> lty
+                      _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
+
+    tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan)
+    -- Make a default-method Id of the appropriate type
+    -- That may entail getting the generic-default signature
+    -- from the type signatures.
+    -- Also return the in-scope tyvars for the default method, and their binding site
+    tc_dm_id NoDefMeth         = panic "tc_dm_id"
+    tc_dm_id (DefMeth dm_name) 
+      | Just (tvs, loc) <- sig_fn sel_name
+      = return (mkDefaultMethodId sel_id dm_name, tvs, loc)
+      | otherwise
+      = pprPanic "No sig for" (ppr sel_name)
+    tc_dm_id (GenDefMeth dm_name)
+      = setSrcSpan loc $
+        do { tau <- tcHsKindedType genop_lhs_ty
+          ; checkValidType (FunSigCtxt sel_name) tau   
+           ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau)
+                    , hsExplicitTvs genop_lhs_ty, loc ) }
+      where
+        loc = getLoc genop_lhs_ty
 
 ---------------
 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
@@ -246,7 +248,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] $
@@ -562,6 +564,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), 
index 2988f08..ffa240d 100644 (file)
@@ -40,10 +40,14 @@ import Name
 import NameSet
 import TyCon
 import TcType
+import BuildTyCl
+import BasicTypes
 import Var
 import VarSet
 import PrelNames
 import SrcLoc
+import Unique
+import UniqSupply
 import Util
 import ListSetOps
 import Outputable
@@ -292,12 +296,14 @@ 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
@@ -313,14 +319,27 @@ 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)
+                -- Generate the (old) generic to/from functions from each type declaration
+       ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+       
+        -- Generate the generic Representable0/1 instances from each type declaration
+  ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
+       
+       ; let repInsts   = concat (map (\(a,b,c) -> a) repInstsMeta)
+             repMetaTys = map (\(a,b,c) -> b) repInstsMeta
+             repTyCons  = map (\(a,b,c) -> c) repInstsMeta
+       -- Should we extendLocalInstEnv with repInsts?
+
+       ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ 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
@@ -1463,6 +1482,133 @@ genDerivBinds loc fix_env clas tycon
               ,(foldableClassKey, gen_Foldable_binds)
               ,(traversableClassKey, gen_Traversable_binds)
               ]
+
+-- Generate the binds for the generic representation
+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 ])
+
+genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds)
+                                  , MetaTyCons, TyCon)
+genGenericRepBind tc =
+  do  clas <- tcLookupClass rep0ClassName
+      uniqS <- newUniqueSupply
+      dfun_name <- new_dfun_name clas tc
+      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..] ]
+        tvs       = tyConTyVars tc
+        tc_ty     = mkTyConApp tc (mkTyVarTys tvs)
+        
+        mkTyCon name = ASSERT( isExternalName name )
+                         buildAlgTyCon name [] [] mkAbstractTyConRhs
+                           NonRecursive False 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
+
+      let
+        mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds }
+                               , [ {- No DerivAuxBinds -} ])
+        inst  = mkLocalInstance dfun NoOverlap
+        binds = VanillaInst (mkBindsRep0 tc) [] False
+        
+        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 2c04cf4..362ac5d 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..0ffc466 100644 (file)
@@ -397,12 +397,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 -- 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
+                               -- try the deriving stuff, because that may give
                                -- more errors still
-       ; (deriv_inst_info, deriv_binds, deriv_dus) 
+       ; (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
-       ; return ( addTcgDUs gbl_env deriv_dus,
+
+       -- 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
+--       ; traceTc "Generic deriving" (vcat (map pprInstInfo deriv_inst_info))
+         ; return ( addTcgDUs gbl_env deriv_dus,
                   generic_inst_info ++ deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
     }}}
@@ -917,10 +923,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     ----------------------
     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+    -- JPM: This is probably not that simple...
+    tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name)
+{-
     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 3de19ed..d429a78 100644 (file)
@@ -299,7 +299,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
@@ -500,7 +500,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 {
@@ -847,7 +847,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       $
@@ -885,8 +885,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 ;
index a433d69..653394f 100644 (file)
@@ -61,12 +61,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 +91,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 +111,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
@@ -488,6 +493,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 {})
@@ -702,7 +709,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) 
+           (want_generic && canDoGenerics stupid_theta data_cons) (not h98_syntax) 
             NoParentTyCon Nothing
        })
   ; return [ATyCon tycon]
@@ -1134,7 +1141,7 @@ 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) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
@@ -1157,8 +1164,10 @@ checkValidClass cls
 
                -- Check that for a generic method, the type of 
                -- the method is sufficiently simple
+{- -- JPM TODO
        ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
                  (badGenericMethodType op_name op_ty)
+-}
        }
        where
          op_name = idName sel_id
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..6d1a2df 100644 (file)
 -- for details
 
 module Generics ( canDoGenerics, mkTyConGenericBinds,
-                 mkGenericRhs, 
-                 validGenericInstanceType, validGenericMethodType
+                 mkGenericRhs,
+                 validGenericInstanceType, validGenericMethodType,
+                 mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+                 MetaTyCons(..), metaTyCons2TyCons
     ) where
 
 
@@ -22,14 +24,21 @@ import TcType
 import DataCon
 
 import TyCon
-import Name
+import Name hiding (varName)
+import OccName (varName)
+import Module (moduleName, moduleNameString)
 import RdrName
 import BasicTypes
-import Var
+import Var hiding (varName)
 import VarSet
 import Id
 import TysWiredIn
 import PrelNames
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad (TcM, newUnique)
+import TcMType (newMetaTyVar)
+import HscTypes
        
 import SrcLoc
 import Util
@@ -37,6 +46,9 @@ import Bag
 import Outputable 
 import FastString
 
+import Data.List (splitAt)
+import Debug.Trace (trace)
+
 #include "HsVersions.h"
 \end{code}
 
@@ -226,14 +238,18 @@ validGenericMethodType ty
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: ThetaType -> [DataCon] -> 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
+canDoGenerics stupid_theta data_cons
   =  not (any bad_con data_cons)       -- See comment below
-  && not (null data_cons)              -- No values of the type
+  
+  -- && not (null data_cons)           -- No values of the type
+  -- JPM: we now support empty datatypes
+  
+     && null stupid_theta -- We do not support datatypes with context (for now)
   where
     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
        -- If any of the constructor has an unboxed type as argument,
@@ -245,6 +261,8 @@ canDoGenerics data_cons
 
        -- Nor if the args are polymorphic types (I don't think)
     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+  -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it
+       -- like this for now...
 \end{code}
 
 %************************************************************************
@@ -255,137 +273,351 @@ canDoGenerics data_cons
 
 \begin{code}
 type US = Int  -- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
-
+type Alt = (LPat RdrName, LHsExpr RdrName)
+{-
+data GenRep = GenRep {
+    genBindsFrom0 :: TyCon -> LHsBinds RdrName
+  , genBindsTo0 :: TyCon -> LHsBinds RdrName
+  , genBindsFrom1 :: TyCon -> LHsBinds RdrName
+  , genBindsTo1 :: TyCon -> LHsBinds RdrName
+  , genBindsModuleName :: TyCon -> LHsBinds RdrName
+  , genBindsConName :: DataCon -> LHsBinds RdrName
+  , genBindsConFixity :: DataCon -> LHsBinds RdrName
+  , genBindsConIsRecord :: DataCon -> LHsBinds RdrName
+  , genBindsSelName :: DataCon -> Int -> LHsBinds 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
+        
+-- Disabled
 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))
+mkTyConGenericBinds tycon = 
+  {-
+    unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
+  `unionBags`
+    unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
+  `unionBags`
+    mkMeta loc tycon
+  -}
+    emptyBag
+{-
   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
+    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
+    (from0_RDR, to0_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])))
+    from0_alts, to0_alts :: [Alt]
+    (from0_alts, to0_alts) = mkSum init_us tycon datacons
+    init_us = 1 :: US -- Unique supply
+-}
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+{-
+mkRep0Ty :: TyCon -> LHsType Name
+mkRep0Ty tycon = res
+  where
+    res = d1 `nlHsAppTy` (cons datacons)
+    d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO
+    c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO
+    s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO
+    plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b
+    times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b
+    k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x
+    
+    datacons = tyConDataCons tycon
+    n_args datacon = dataConSourceArity datacon
+    datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon]
+        
+    cons ds = c1 `nlHsAppTy` sum ds
+    sum [] = nlHsTyVar v1TyConName
+    sum l  = foldBal plus (map sel l)
+    sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d)
+    prod [] = nlHsTyVar u1TyConName
+    prod l  = foldBal times (map arg l)
+    arg :: Type -> LHsType Name
+    -- TODO
+    arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO
+-}
+
+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
+    u1 <- tcLookupTyCon u1TyConName
+    v1 <- tcLookupTyCon v1TyConName
+    plus <- tcLookupTyCon sumTyConName
+    times <- tcLookupTyCon prodTyConName
+    noSel <- tcLookupTyCon noSelTyConName
+    freshTy <- newMetaTyVar TauTv liftedTypeKind
+    
+    let mkSum  a b = mkTyConApp plus  [a,b]
+        mkProd a b = mkTyConApp times [a,b]
+        mkRec0 a   = mkTyConApp rec0  [a]
+        mkD    a   = mkTyConApp d1    [metaDTyCon, sum (tyConDataCons a)]
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a)]
+        mkS    d a = mkTyConApp s1    [d, a]
+        
+        sum [] = mkTyConTy v1
+        sum 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 (mkRec0 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 mod     = nameModule  (tyConName tycon)
+        loc     = nameSrcSpan (tyConName tycon)
+        -- `repName` is a name we generate for the synonym
+        repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc
+        -- `coName` is a name for the coercion
+        coName  = mkExternalName uniq2 mod (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 (isTupleCon c)
+                                   [(conIsTuple_RDR
+                                    ,conIsTuple_matches (dataConTyCon 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 c = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+        -- TODO: check that this works
+        conIsTuple_matches  c = [mkSimpleHsAlt nlWildPat 
+                                  (nlHsApp (nlHsVar arityDataCon_RDR) 
+                                           (nlHsIntLit 
+                                             (toInteger (tupleTyConArity c))))]
+
+        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
-    (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))])))
+    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 us []   = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E us vars = mkM1_E (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_E vars
+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+-- TODO: Produce a P0 when v is a parameter
+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 us []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P us vars = mkM1_P (foldBal prod appVars)
+                   -- These M1s are meta-information for the constructor
+  where
+    appVars = map wrapArg_P vars
+    prod a b = prodDataCon_RDR `nlConPat` [a,b]
+    
+-- TODO: Produce a P0 when v is a parameter
+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))
@@ -399,6 +631,23 @@ mkGenericNames tycon
     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)
+    
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
+
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
+
+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
+
 \end{code}
 
 %************************************************************************
index adb0470..0baa312 100644 (file)
@@ -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,
@@ -1087,6 +1087,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