Add a new flag XDefaultSignatures to enable just the signatures on the default methods. Redefine the behavior of XGenerics to mean enable XDefaultSignatures and XDeriveRepresentable.

6 files changed, 41 insertions, 47 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 9ebede6351..e6cad1ab9a 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -597,8 +597,8 @@ 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
+        -- A type signature for a default method inside a class
+        -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
   | GenericSig (Located name) (LHsType name)
 
 	-- A type signature in generated code, notably the code
@@ -734,7 +734,7 @@ isInlineLSig _                    = False
 
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {}) 		= ptext (sLit "type signature")
-hsSigDoc (GenericSig {})	= ptext (sLit "generic default type signature")
+hsSigDoc (GenericSig {})	= ptext (sLit "default type signature")
 hsSigDoc (IdSig {}) 		= ptext (sLit "id signature")
 hsSigDoc (SpecSig {})	 	= ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
@@ -763,7 +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 (GenericSig var ty)	  = ptext (sLit "default") <+> 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)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ed64fd0ad9..53790ccea3 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -321,7 +321,6 @@ data ExtensionFlag
    | Opt_TemplateHaskell
    | Opt_QuasiQuotes
    | Opt_ImplicitParams
-   | Opt_Generics			-- generic deriving mechanism
    | Opt_ImplicitPrelude
    | Opt_ScopedTypeVariables
    | Opt_UnboxedTuples
@@ -343,7 +342,9 @@ data ExtensionFlag
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
-   | Opt_DeriveRepresentable
+   | Opt_DeriveRepresentable            -- Allow deriving Representable0/1
+   | Opt_DefaultSignatures              -- Allow extra signatures for defmeths
+   | Opt_Generics                       -- Generic deriving mechanism
 
    | Opt_TypeSynonymInstances
    | Opt_FlexibleContexts
@@ -1679,6 +1680,7 @@ xFlags = [
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
   ( "DeriveRepresentable",              Opt_DeriveRepresentable, nop ),
+  ( "DefaultSignatures",                Opt_DefaultSignatures, nop ),
   ( "TypeSynonymInstances",             Opt_TypeSynonymInstances, nop ),
   ( "FlexibleContexts",                 Opt_FlexibleContexts, nop ),
   ( "FlexibleInstances",                Opt_FlexibleInstances, nop ),
@@ -1744,6 +1746,9 @@ impliedFlags
     , (Opt_RecordWildCards,     turnOn, Opt_DisambiguateRecordFields)
     
     , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp)
+    -- The new behavior of the XGenerics flag is just to turn on these two flags
+    , (Opt_Generics, turnOn, Opt_DefaultSignatures)
+    , (Opt_Generics, turnOn, Opt_DeriveRepresentable)
   ]
 
 optLevelFlags :: [([Int], DynFlag)]
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 7aa2654ca9..21fbb5acf1 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -814,8 +814,8 @@ checkValSig lhs@(L l _) ty
   where
     hint = if foreign_RDR `looks_like` lhs
            then "Perhaps you meant to use -XForeignFunctionInterface?"
-           else if generic_RDR `looks_like` lhs
-                then "Perhaps you meant to use -XGenerics?"
+           else if default_RDR `looks_like` lhs
+                then "Perhaps you meant to use -XDefaultSignatures?"
                 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
@@ -825,7 +825,7 @@ checkValSig lhs@(L l _) ty
     looks_like _ _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
-    generic_RDR = mkUnqual varName (fsLit "generic")
+    default_RDR = mkUnqual varName (fsLit "default")
 
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index b0dd3b52f4..4371a2c224 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -713,8 +713,8 @@ renameSig mb_names sig@(TypeSig 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))
+  = do	{ defaultSigs_on <- xoptM Opt_DefaultSignatures
+        ; unless defaultSigs_on (addErr (defaultSigErr sig))
         ; new_v <- lookupSigOccRn mb_names sig v
 	; new_ty <- rnHsSigType (quotes (ppr v)) ty
 	; return (GenericSig new_v new_ty) } -- JPM: ?
@@ -840,10 +840,10 @@ 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:"))
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
                               2 (ppr sig)
-                         , ptext (sLit "Use -XGenerics to enable generic default signatures") ] 
+                         , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ] 
 
 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
 methodBindErr mbind
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 2bd438d489..a6815438b3 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -460,6 +460,7 @@ 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
@@ -470,8 +471,8 @@ mkGenDerivSpec tc = do
         ; let mtheta    = Just []
         ; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta
         -- JPM TODO: StandAloneDerivOrigin?...
-        ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds }
-
+        ; return ds }
+-}
 -- Make the "extras" for the generic representation
 mkGenDerivExtras :: TyCon 
                  -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
@@ -494,9 +495,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
   = do	{ eqns1 <- mapAndRecoverM deriveTyData all_tydata
 	; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
         -- Generate EarlyDerivSpec's for Representable, if asked for
-	; (xGenerics, xDeriveRepresentable) <- genericsFlags
+	-- ; (xGenerics, xDerRep) <- genericsFlags
+	; xDerRep <- genericsFlag
 	; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
-        ; allTyDecls <- mapM tcLookupTyCon allTyNames
+        -- ; 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 ]
@@ -504,7 +506,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
                                   | L _ (DerivDecl (L _ t)) <- deriv_decls
                                   , getClassName t == Just rep0ClassName ] 
         ; derTyDecls <- mapM tcLookupTyCon $ 
-                         filter (needsExtras xDeriveRepresentable
+                         filter (needsExtras xDerRep
                                   (sel_tydata ++ sel_deriv_decls)) allTyNames
         -- We need to generate the extras to add to what has
         -- already been derived
@@ -512,6 +514,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
         -- 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
@@ -520,24 +523,14 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
         ; 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) }
+        -- Merge and return everything
+	; 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 
+      -- We need extras if the flag DeriveRepresentable is on and this type is 
       -- deriving Representable
-      xDeriveRepresentable && tc_name `elem` tydata
+    needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
 
     -- Extracts the name of the class in the deriving
     getClassName :: HsType Name -> Maybe Name
@@ -546,8 +539,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
     -- Extracts the name of the type in the deriving
     getTypeName :: HsType Name -> Maybe Name
-    getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
-    getTypeName _                                         = Nothing
+    getTypeName (HsTyVar n)                     = Just n
+    getTypeName (HsOpTy _ (L _ n) _)            = Just n
+    getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+    getTypeName _                               = Nothing
 
     extractTyDataPreds decls
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
@@ -563,10 +558,10 @@ 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)
+genericsFlag :: TcM Bool
+genericsFlag = do dOpts <- getDOpts
+                  return (  xopt Opt_Generics            dOpts
+                         || xopt Opt_DeriveRepresentable dOpts)
 
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
@@ -965,7 +960,7 @@ orCond c1 c2 tc
 	Nothing -> Nothing	    -- c1 succeeds
 	Just x  -> case c2 tc of    -- c1 fails
 		     Nothing -> Nothing
-		     Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
+		     Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
 			            -- Both fail
 
 andCond :: Condition -> Condition -> Condition
diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index b608128a25..50b6b96a03 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -50,12 +50,6 @@ 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)