diff options
| -rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 8 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 9 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 6 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.lhs | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 49 | ||||
| -rw-r--r-- | compiler/types/Generics.lhs | 6 |
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) |