Add a new flag XDefaultSignatures to enable just the signatures on the default method...

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 9ebede6..e6cad1a 100644 (file)
--- 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)
 
        -- 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
   | 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 :: 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")
 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 :: 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)
 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 ed64fd0..53790cc 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -321,7 +321,6 @@ data ExtensionFlag
    | Opt_TemplateHaskell
    | Opt_QuasiQuotes
    | Opt_ImplicitParams
    | Opt_TemplateHaskell
    | Opt_QuasiQuotes
    | Opt_ImplicitParams

-   | Opt_Generics                      -- generic deriving mechanism

    | Opt_ImplicitPrelude
    | Opt_ScopedTypeVariables
    | Opt_UnboxedTuples
    | Opt_ImplicitPrelude
    | Opt_ScopedTypeVariables
    | Opt_UnboxedTuples

@@ -343,7 +342,9 @@ data ExtensionFlag
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
    | 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
 
    | Opt_TypeSynonymInstances
    | Opt_FlexibleContexts

@@ -1679,6 +1680,7 @@ xFlags = [
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
   ( "DeriveRepresentable",              Opt_DeriveRepresentable, nop ),
   ( "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 ),
   ( "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)
     , (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)]
   ]
 
 optLevelFlags :: [([Int], DynFlag)]

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 7aa2654..21fbb5a 100644 (file)
--- 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?"
   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
                 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")
     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
 
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index b0dd3b5..4371a2c 100644 (file)
--- 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)
        ; 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: ?
         ; 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]
 
   = 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)
                               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
 
 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
 methodBindErr mbind

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 2bd438d..a681543 100644 (file)
--- 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}
 @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
 -- 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?...
         ; 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)])
 -- 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
   = 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 ]
        ; 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 ]
         -- 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 $ 
                                   | 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
                                   (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.
         -- 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
         ; 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 []
         ; 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
   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
       -- 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
 
     -- 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
 
     -- 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]
 
     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")))
 
                        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
 
 ------------------------------------------------------------------
 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
        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
                                    -- Both fail
 
 andCond :: Condition -> Condition -> Condition

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index b608128..50b6b96 100644 (file)
--- 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)
   =  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)
 
                   -- We don't like type families
                   && not (isFamilyTyCon tycon)