diff options
| -rw-r--r-- | compiler/basicTypes/BasicTypes.lhs | 1 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 90 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.lhs | 31 | ||||
| -rw-r--r-- | docs/users_guide/flags.xml | 7 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.xml | 96 | ||||
| -rw-r--r-- | testsuite/tests/driver/T4437.hs | 1 | ||||
| -rw-r--r-- | testsuite/tests/generics/GEnum/Enum.hs | 87 | ||||
| -rw-r--r-- | testsuite/tests/generics/GEq/GEq1A.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462No1.hs | 27 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462No1.stderr | 20 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462Yes1.hs | 48 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462Yes1.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462Yes2.hs | 37 | ||||
| -rw-r--r-- | testsuite/tests/generics/T5462Yes2.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/generics/all.T | 12 | ||||
| -rw-r--r-- | testsuite/tests/module/mod53.stderr | 1 |
17 files changed, 398 insertions, 67 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 4fbfb6007a..252d0fe5d7 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -736,6 +736,7 @@ Class object. data DefMethSpec = NoDM -- No default method | VanillaDM -- Default method given with polymorphic code | GenericDM -- Default method given with generic code + deriving Eq instance Outputable DefMethSpec where ppr NoDM = empty diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3fa2c5f335..9105d7ff82 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -564,6 +564,7 @@ data ExtensionFlag | Opt_DeriveFoldable | Opt_DeriveGeneric -- Allow deriving Generic/1 | Opt_DefaultSignatures -- Allow extra signatures for defmeths + | Opt_DeriveAnyClass -- Allow deriving any class | Opt_TypeSynonymInstances | Opt_FlexibleContexts @@ -2873,6 +2874,7 @@ xFlags = [ $ deprecate $ "It was widely considered a misfeature, " ++ "and has been removed from the Haskell language." ), ( "DefaultSignatures", Opt_DefaultSignatures, nop ), + ( "DeriveAnyClass", Opt_DeriveAnyClass, nop ), ( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ), ( "DeriveFoldable", Opt_DeriveFoldable, nop ), ( "DeriveFunctor", Opt_DeriveFunctor, nop ), diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index c662b18b20..c76d19edce 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -530,8 +530,8 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls -- If AutoDeriveTypeable is set, we automatically add Typeable instances -- for every data type and type class declared in the module - ; auto_typeable <- xoptM Opt_AutoDeriveTypeable - ; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls + ; auto_typeable <- xoptM Opt_AutoDeriveTypeable + ; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls ; let eqns = eqns1 ++ eqns2 ++ eqns3 ++ eqns4 @@ -782,7 +782,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) -- newtype K a a = ... deriving( Monad ) ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') - cls final_cls_tys tc final_tc_args Nothing + cls final_cls_tys tc final_tc_args Nothing ; return [spec] } } derivePolyKindedTypeable :: Bool -> Class -> [Type] @@ -1001,9 +1001,10 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions - CanDerive -> go_for_it - NonDerivableClass -> bale_out (nonStdErr cls) + NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg) DerivableClassError msg -> bale_out msg + CanDerive -> go_for_it + DerivableViaInstance -> go_for_it where go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) @@ -1049,7 +1050,7 @@ mkPolyKindedTypeableEqn cls tc 2 (ptext (sLit "You need DeriveDataTypeable to derive Typeable instances"))) ; loc <- getSrcSpanM - ; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc) + ; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc) ; mapM (mk_one loc) (tc : prom_dcs) } where mk_one loc tc = do { traceTc "mkPolyKindedTypeableEqn" (ppr tc) @@ -1112,7 +1113,11 @@ inferConstraints cls inst_tys rep_tc rep_tc_args -- (a) We recurse over argument types to generate constraints -- See Functor examples in TcGenDeriv -- (b) The rep_tc_args will be one short - is_functor_like = getUnique cls `elem` functorLikeClassKeys + is_functor_like = getUnique cls `elem` functorLikeClassKeys + || onlyOneAndTypeConstr inst_tys + onlyOneAndTypeConstr [inst_ty] = + typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind + onlyOneAndTypeConstr _ = False get_std_constrained_tys :: Type -> [Type] get_std_constrained_tys ty @@ -1165,6 +1170,37 @@ We have some special hacks to support things like Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int (which we know how to show). It's a bit ad hoc. +Note [Deriving any class] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, you can use a deriving clause, or standalone-deriving declaration, +only for: + * a built-in class like Eq or Show, for which GHC knows how to generate + the instance code + * a newtype, via the "newtype-deriving" mechanism. + +However, with GHC.Generics we can write this: + + data T a = ...blah..blah... deriving( Generic ) + instance C a => C (T a) -- No 'where' clause + +where C is some "random" user-defined class. Usually, an instance decl with no +'where' clause would be pretty useless, but now that we have default method +signatures, in conjunction with deriving( Generic ), the instance can be useful. + +That in turn leads to a desire to say + + data T a = ...blah..blah... deriving( Generic, C ) + +which is even more compact. That is what DeriveAnyClass implements. This is +not restricted to Generics; any class can be derived, simply giving rise to +an empty instance. + +The only thing left to answer is how to determine the context (in case of +standard deriving; in standalone deriving, the user provides the context). +GHC uses the same heuristic for figuring out the class context that it uses for +Eq in the case of *-kinded classes, and for Functor in the case of +* -> *-kinded classes. That may not be optimal or even wrong. But in such +cases, standalone deriving can still be used. \begin{code} ------------------------------------------------------------------ @@ -1177,7 +1213,8 @@ Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int data DerivStatus = CanDerive | DerivableClassError SDoc -- Standard class, but can't do it - | NonDerivableClass -- Non-standard class + | DerivableViaInstance -- See Note [Deriving any class] + | NonDerivableClass SDoc -- Non-standard class checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> [Type] -- tycon and its parameters @@ -1190,7 +1227,8 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args -- cls_tys (the type args other than last) -- should be null | otherwise -> DerivableClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s ) - | otherwise = NonDerivableClass -- Not a standard class + | otherwise = maybe DerivableViaInstance NonDerivableClass + (canDeriveAnyClass dflags rep_tc cls) classArgsErr :: Class -> [Type] -> SDoc classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") @@ -1225,7 +1263,7 @@ sideConditions mtheta cls | cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond` cond_vanilla `andCond` cond_Representable1Ok) - | otherwise = Nothing + | otherwise = Nothing where cls_key = getUnique cls cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one, @@ -1495,7 +1533,8 @@ mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... | ASSERT( length cls_tys + 1 == classArity cls ) - might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls) + might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass) + || std_class_via_coercible cls) = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds) dfun_name <- new_dfun_name cls tycon loc <- getSrcSpanM @@ -1518,18 +1557,29 @@ mkNewTypeEqn dflags overlap_mode tvs , ds_newtype = True } | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of - CanDerive -> go_for_it -- Use the standard H98 method - DerivableClassError msg -- Error with standard class + -- Error with standard class + DerivableClassError msg | might_derive_via_coercible -> bale_out (msg $$ suggest_nd) | otherwise -> bale_out msg - NonDerivableClass -- Must use newtype deriving - | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving - | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving! + -- Must use newtype deriving or DeriveAnyClass + NonDerivableClass _msg + -- Too hard, even with newtype deriving + | newtype_deriving -> bale_out cant_derive_err + -- Try newtype deriving! + | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd) | otherwise -> bale_out non_std + -- CanDerive/DerivableViaInstance + _ -> do when (newtype_deriving && deriveAnyClass) $ + addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled") + , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ]) + go_for_it where - newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags - go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tycon rep_tc_args mtheta - bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) + newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags + deriveAnyClass = xopt Opt_DeriveAnyClass dflags + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args + rep_tycon rep_tc_args mtheta + bale_out = bale_out' newtype_deriving + bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty non_std = nonStdErr cls suggest_nd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension") @@ -2041,7 +2091,7 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe Note [Bindings for Generalised Newtype Deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider +Consider class Eq a => C a where f :: a -> a newtype N a = MkN [a] deriving( C ) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 31e31ed34f..df45001870 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -17,7 +17,8 @@ This is where we do all the grimy bindings' generation. module TcGenDeriv ( BagDerivStuff, DerivStuff(..), - genDerivedBinds, + canDeriveAnyClass, + genDerivedBinds, FFoldType(..), functorLikeTraverse, deepSubtypesContaining, foldDataConArgs, mkCoerceClassMethEqn, @@ -65,8 +66,9 @@ import Bag import Fingerprint import TcEnv (InstInfo) -import ListSetOps( assocMaybe ) -import Data.List ( partition, intersperse ) +import ListSetOps ( assocMaybe ) +import Data.List ( partition, intersperse ) +import Data.Maybe ( isNothing ) \end{code} \begin{code} @@ -106,7 +108,12 @@ genDerivedBinds dflags fix_env clas loc tycon = gen_fn loc tycon | otherwise - = pprPanic "genDerivStuff: bad derived class" (ppr clas) + -- Deriving any class simply means giving an empty instance, so no + -- bindings have to be generated. + = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas) + , ppr "genDerivStuff: bad derived class" <+> ppr clas ) + (emptyBag, emptyBag) + where gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] gen_list = [ (eqClassKey, gen_Eq_binds) @@ -121,6 +128,20 @@ genDerivedBinds dflags fix_env clas loc tycon , (functorClassKey, gen_Functor_binds) , (foldableClassKey, gen_Foldable_binds) , (traversableClassKey, gen_Traversable_binds) ] + + +-- Nothing: we can (try to) derive it via Generics +-- Just s: we can't, reason s +canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc +canDeriveAnyClass dflags _tycon clas = + let b `orElse` s = if b then Nothing else Just (ptext (sLit s)) + Just m <> _ = Just m + Nothing <> n = n + -- We can derive a given class for a given tycon via Generics iff + in -- 1) The class is not a "standard" class (like Show, Functor, etc.) + (not (getUnique clas `elem` standardClassKeys) `orElse` "") + -- 2) Opt_DeriveAnyClass is on + <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass") \end{code} %************************************************************************ @@ -1231,7 +1252,7 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon +gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Typeable_binds dflags loc tycon = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat] diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 5c5e05e1d9..c1ef0f0e5c 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -806,6 +806,13 @@ <entry><option>-XNoDefaultSignatures</option></entry> </row> <row> + <entry><option>-XDeriveAnyClass</option></entry> + <entry>Enable <link linkend="derive-any-class">deriving for any + class</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoDeriveAnyClass</option></entry> + </row> + <row> <entry><option>-XDeriveDataTypeable</option></entry> <entry>Enable <link linkend="deriving-typeable">deriving for the Data and Typeable classes</link>. Implied by <option>-XAutoDeriveTypeable</option>.</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 51d7b731e4..30742b333d 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -456,10 +456,10 @@ Indeed, the bindings can even be recursive. </para> <para> - This can make a difference when the positive and negative range of - a numeric data type don't match up. For example, + This can make a difference when the positive and negative range of + a numeric data type don't match up. For example, in 8-bit arithmetic -128 is representable, but +128 is not. - So <literal>negate (fromInteger 128)</literal> will elicit an + So <literal>negate (fromInteger 128)</literal> will elicit an unexpected integer-literal-overflow message. </para> </sect2> @@ -998,7 +998,7 @@ synonym using the following syntax: <para> The syntax and semantics of pattern synonyms are elaborated in the -following subsections. +following subsections. See the <ulink url="http://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms">Wiki page</ulink> for more details. @@ -2533,10 +2533,10 @@ import safe qualified Network.Socket as NS <sect3 id="explicit-namespaces"> <title>Explicit namespaces in import/export</title> -<para> In an import or export list, such as +<para> In an import or export list, such as <programlisting> module M( f, (++) ) where ... - import N( f, (++) ) + import N( f, (++) ) ... </programlisting> the entities <literal>f</literal> and <literal>(++)</literal> are <emphasis>values</emphasis>. @@ -2545,12 +2545,12 @@ to declare <literal>(++)</literal> as a <emphasis>type constructor</emphasis>. case, how would you export or import it? </para> <para> -The <option>-XExplicitNamespaces</option> extension allows you to prefix the name of -a type constructor in an import or export list with "<literal>type</literal>" to +The <option>-XExplicitNamespaces</option> extension allows you to prefix the name of +a type constructor in an import or export list with "<literal>type</literal>" to disambiguate this case, thus: <programlisting> module M( f, type (++) ) where ... - import N( f, type (++) ) + import N( f, type (++) ) ... module N( f, type (++) ) where data family a ++ b = L a | R b @@ -2854,11 +2854,11 @@ allow you to write them infix. The language <option>-XTypeOperators</option> changes this behaviour: <itemizedlist> <listitem><para> -Operator symbols become type <emphasis>constructors</emphasis> rather than +Operator symbols become type <emphasis>constructors</emphasis> rather than type <emphasis>variables</emphasis>. </para></listitem> <listitem><para> -Operator symbols in types can be written infix, both in definitions and uses. +Operator symbols in types can be written infix, both in definitions and uses. for example: <programlisting> data a + b = Plus a b @@ -2867,8 +2867,8 @@ type Foo = Int + Bool </para></listitem> <listitem><para> There is now some potential ambiguity in import and export lists; for example -if you write <literal>import M( (+) )</literal> do you mean the -<emphasis>function</emphasis> <literal>(+)</literal> or the +if you write <literal>import M( (+) )</literal> do you mean the +<emphasis>function</emphasis> <literal>(+)</literal> or the <emphasis>type constructor</emphasis> <literal>(+)</literal>? The default is the former, but with <option>-XExplicitNamespaces</option> (which is implied by <option>-XExplicitTypeOperators</option>) GHC allows you to specify the latter @@ -3973,7 +3973,7 @@ defined in <literal>GHC.Base</literal>. <listitem><para> With <option>-XDeriveDataTypeable</option>, you can derive instances of the class <literal>Data</literal>, -defined in <literal>Data.Data</literal>. See <xref linkend="deriving-typeable"/> for +defined in <literal>Data.Data</literal>. See <xref linkend="deriving-typeable"/> for deriving <literal>Typeable</literal>. </para></listitem> @@ -3985,7 +3985,7 @@ defined in <literal>Data.Foldable</literal>. <listitem><para> With <option>-XDeriveTraversable</option>, you can derive instances of the class <literal>Traversable</literal>, defined in <literal>Data.Traversable</literal>. Since the <literal>Traversable</literal> -instance dictates the instances of <literal>Functor</literal> and +instance dictates the instances of <literal>Functor</literal> and <literal>Foldable</literal>, you'll probably want to derive them too, so <option>-XDeriveTraversable</option> implies <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>. @@ -4017,9 +4017,9 @@ programmer cannot subert the type system by writing bogus instances. </para></listitem> <listitem><para> -With <option>-XDeriveDataTypeable</option> +With <option>-XDeriveDataTypeable</option> GHC allows you to derive instances of <literal>Typeable</literal> for data types or newtypes, -using a <literal>deriving</literal> clause, or using +using a <literal>deriving</literal> clause, or using a standalone deriving declaration (<xref linkend="stand-alone-deriving"/>). </para></listitem> @@ -4044,7 +4044,7 @@ a <literal>Typeable</literal> instance for a type class. <listitem><para> The flag <option>-XAutoDeriveTypeable</option> triggers the generation -of derived <literal>Typeable</literal> instances for every datatype, data family, +of derived <literal>Typeable</literal> instances for every datatype, data family, and type class declaration in the module it is used, unless a manually-specified one is already provided. This flag implies <option>-XDeriveDataTypeable</option>. @@ -4185,7 +4185,7 @@ A derived instance is derived only for declarations of these forms (after expans where <itemizedlist> <listitem><para> -<literal>v1..vn</literal> are type variables, and <literal>t</literal>, +<literal>v1..vn</literal> are type variables, and <literal>t</literal>, <literal>s1..sk</literal>, <literal>t1..tj</literal> are types. </para></listitem> <listitem><para> @@ -4263,6 +4263,25 @@ the standard method is used or the one described here.) </para> </sect3> </sect2> + +<sect2 id="derive-any-class"> +<title>Deriving any other class</title> + +<para> +With <option>-XDeriveAnyClass</option> you can derive any other class. The +compiler will simply generate an empty instance. The instance context will be +generated according to the same rules used when deriving <literal>Eq</literal>. +This is mostly useful in classes whose <link linkend="minimal-pragma">minimal +set</link> is empty, and especially when writing +<link linkend="generic-programming">generic functions</link>. + +In case you try to derive some class on a newtype, and +<option>-XGeneralizedNewtypeDeriving</option> is also on, +<option>-XDeriveAnyClass</option> takes precedence. +</para> + +</sect2> + </sect1> @@ -5144,7 +5163,7 @@ These rules make it possible for a library author to design a library that relie overlapping instances without the client having to know. </para> <para> -Errors are reported <emphasis>lazily</emphasis> (when attempting to solve a constraint), rather than <emphasis>eagerly</emphasis> +Errors are reported <emphasis>lazily</emphasis> (when attempting to solve a constraint), rather than <emphasis>eagerly</emphasis> (when the instances themselves are defined). Consider, for example <programlisting> instance C Int b where .. @@ -6128,7 +6147,7 @@ instance Eq (Elem [e]) => Collects [e] where </para></listitem> <listitem><para> The instance for an associated type can be omitted in class instances. In that case, - unless there is a default instance (see <xref linkend="assoc-decl-defs"/>), + unless there is a default instance (see <xref linkend="assoc-decl-defs"/>), the corresponding instance type is not inhabited; i.e., only diverging expressions, such as <literal>undefined</literal>, can assume the type. @@ -7235,13 +7254,13 @@ restriction on class declarations (<xref linkend="superclass-rules"/>) and insta <para> Each user-written type signature is subjected to an -<emphasis>ambiguity check</emphasis>. +<emphasis>ambiguity check</emphasis>. The ambiguity check rejects functions that can never be called; for example: <programlisting> f :: C a => Int </programlisting> The idea is there can be no legal calls to <literal>f</literal> because every call will -give rise to an ambiguous constraint. +give rise to an ambiguous constraint. Indeed, the <emphasis>only</emphasis> purpose of the ambiguity check is to report functions that cannot possibly be called. We could soundly omit the @@ -7253,7 +7272,7 @@ delaying ambiguity errors to call sites. Indeed, the language extension Ambiguity can be subtle. Consider this example which uses functional dependencies: <programlisting> class D a b | a -> b where .. - h :: D Int b => Int + h :: D Int b => Int </programlisting> The <literal>Int</literal> may well fix <literal>b</literal> at the call site, so that signature should not be rejected. Moreover, the dependencies might be hidden. Consider @@ -7268,12 +7287,12 @@ Here <literal>h</literal>'s type looks ambiguous in <literal>b</literal>, but he ...(h [True])... </programlisting> That gives rise to a <literal>(X [Bool] beta)</literal> constraint, and using the -instance means we need <literal>(D Bool beta)</literal> and that +instance means we need <literal>(D Bool beta)</literal> and that fixes <literal>beta</literal> via <literal>D</literal>'s fundep! </para> <para> -Behind all these special cases there is a simple guiding principle. +Behind all these special cases there is a simple guiding principle. Consider <programlisting> f :: <replaceable>type</replaceable> @@ -7283,7 +7302,7 @@ Consider g = f </programlisting> You would think that the definition of <literal>g</literal> would surely typecheck! -After all <literal>f</literal> has exactly the same type, and <literal>g=f</literal>. +After all <literal>f</literal> has exactly the same type, and <literal>g=f</literal>. But in fact <literal>f</literal>'s type is instantiated and the instantiated constraints are solved against the constraints bound by <literal>g</literal>'s signature. So, in the case an ambiguous type, solving will fail. @@ -7337,7 +7356,7 @@ GHC used to impose some more restrictive and less principled conditions on type signatures. For type type <literal>forall tv1..tvn (c1, ...,cn) => type</literal> GHC used to require (a) that each universally quantified type variable -<literal>tvi</literal> must be "reachable" from <literal>type</literal>, +<literal>tvi</literal> must be "reachable" from <literal>type</literal>, and (b) that every constraint <literal>ci</literal> mentions at least one of the universally quantified type variables <literal>tvi</literal>. These ad-hoc restrictions are completely subsumed by the new ambiguity check. @@ -8350,9 +8369,9 @@ using the following rules: <listitem><para> A binding group is <emphasis>fully generalised</emphasis> if and only if - <itemizedlist> + <itemizedlist> <listitem><para>each of its free variables is either imported or closed, and</para></listitem> - <listitem><para>the binding is not affected by the monomorphism restriction + <listitem><para>the binding is not affected by the monomorphism restriction (<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.5">Haskell Report, Section 4.5.5</ulink>)</para></listitem> </itemizedlist> </para></listitem> @@ -8751,7 +8770,7 @@ h z = z-1 </programlisting> This abbreviation makes top-level declaration slices quieter and less intimidating. </para></listitem> - + <listitem> <para> Binders are lexically scoped. For example, consider the @@ -10191,11 +10210,11 @@ mindef ::= name A comma denotes conjunction, i.e. both sides are required. Conjunction binds stronger than disjunction.</para> <para> - If no MINIMAL pragma is given in the class declaration, it is just as if + If no MINIMAL pragma is given in the class declaration, it is just as if a pragma <literal>{-# MINIMAL op1, op2, ..., opn #-}</literal> was given, where - the <literal>opi</literal> are the methods - (a) that lack a default method in the class declaration, and - (b) whose name that does not start with an underscore + the <literal>opi</literal> are the methods + (a) that lack a default method in the class declaration, and + (b) whose name that does not start with an underscore (c.f. <option>-fwarn-missing-methods</option>, <xref linkend="options-sanity"/>). </para> <para>This warning can be turned off with the flag <option>-fno-warn-missing-methods</option>.</para> @@ -11569,8 +11588,9 @@ general <link linkend="generic-programming">support for generic programming</lin <para> Using a combination of <option>-XDeriveGeneric</option> -(<xref linkend="deriving-typeable"/>) and +(<xref linkend="deriving-typeable"/>), <option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>), +and <option>-XDeriveAnyClass</option> (<xref linkend="derive-any-class"/>), you can easily do datatype-generic programming using the <literal>GHC.Generics</literal> framework. This section gives a very brief overview of how to do it. @@ -11746,6 +11766,10 @@ instance (Serialize a) => Serialize (UserTree a) The default method for <literal>put</literal> is then used, corresponding to the generic implementation of serialization. +If you are using <option>-XDeriveAnyClass</option>, the same instance is +generated by simply attaching a <literal>deriving Serialize</literal> clause +to the <literal>UserTree</literal> datatype declaration. + For more examples of generic functions please refer to the <ulink url="http://hackage.haskell.org/package/generic-deriving">generic-deriving</ulink> package on Hackage. diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 40ddb4b66b..1dfaa8b03a 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -33,6 +33,7 @@ expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", + "DeriveAnyClass", "JavaScriptFFI", "PatternSynonyms"] diff --git a/testsuite/tests/generics/GEnum/Enum.hs b/testsuite/tests/generics/GEnum/Enum.hs new file mode 100644 index 0000000000..5bf99b45a4 --- /dev/null +++ b/testsuite/tests/generics/GEnum/Enum.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} + +module Enum where + + +import GHC.Generics + + +----------------------------------------------------------------------------- +-- Utility functions for Enum' +----------------------------------------------------------------------------- + +infixr 5 ||| + +-- | Interleave elements from two lists. Similar to (++), but swap left and +-- right arguments on every recursive application. +-- +-- From Mark Jones' talk at AFP2008 +(|||) :: [a] -> [a] -> [a] +[] ||| ys = ys +(x:xs) ||| ys = x : ys ||| xs + +-- | Diagonalization of nested lists. Ensure that some elements from every +-- sublist will be included. Handles infinite sublists. +-- +-- From Mark Jones' talk at AFP2008 +diag :: [[a]] -> [a] +diag = concat . foldr skew [] . map (map (\x -> [x])) + +skew :: [[a]] -> [[a]] -> [[a]] +skew [] ys = ys +skew (x:xs) ys = x : combine (++) xs ys + +combine :: (a -> a -> a) -> [a] -> [a] -> [a] +combine _ xs [] = xs +combine _ [] ys = ys +combine f (x:xs) (y:ys) = f x y : combine f xs ys + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] + in if (null l) + then Nothing + else Just (head l) + +-------------------------------------------------------------------------------- +-- Generic enum +-------------------------------------------------------------------------------- + +class Enum' f where + enum' :: [f a] + +instance Enum' U1 where + enum' = [U1] + +instance (GEnum c) => Enum' (K1 i c) where + enum' = map K1 genum + +instance (Enum' f) => Enum' (M1 i c f) where + enum' = map M1 enum' + +instance (Enum' f, Enum' g) => Enum' (f :+: g) where + enum' = map L1 enum' ||| map R1 enum' + +instance (Enum' f, Enum' g) => Enum' (f :*: g) where + enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] + +instance (GEnum a) => GEnum (Maybe a) +instance (GEnum a) => GEnum [a] + + +genumDefault :: (Generic a, Enum' (Rep a)) => [a] +genumDefault = map to enum' + +class GEnum a where + genum :: [a] + + default genum :: (Generic a, Enum' (Rep a)) => [a] + genum = genumDefault + +instance GEnum Int where + genum = [0..] ||| (neg 0) where + neg n = (n-1) : neg (n-1) diff --git a/testsuite/tests/generics/GEq/GEq1A.hs b/testsuite/tests/generics/GEq/GEq1A.hs index 6450091393..7bdfbebe54 100644 --- a/testsuite/tests/generics/GEq/GEq1A.hs +++ b/testsuite/tests/generics/GEq/GEq1A.hs @@ -37,8 +37,7 @@ class GEq a where instance GEq Char where geq = (==) instance GEq Int where geq = (==) instance GEq Float where geq = (==) -{- + -- Generic instances instance (GEq a) => GEq (Maybe a) instance (GEq a) => GEq [a] --} diff --git a/testsuite/tests/generics/T5462No1.hs b/testsuite/tests/generics/T5462No1.hs new file mode 100644 index 0000000000..fc24f63431 --- /dev/null +++ b/testsuite/tests/generics/T5462No1.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- DeriveAnyClass not enabled + +module T5462No1 where + +import GHC.Generics hiding (C, C1, D) +import GFunctor + +class C1 a where + c1 :: a -> Int + +class C2 a where + c2 :: a -> Int + c2 _ = 0 + +newtype F a = F1 [a] + deriving (Show, Eq, Generic, Generic1, GFunctor) + +data G = G1 deriving (C1) +data H = H1 deriving (C2) diff --git a/testsuite/tests/generics/T5462No1.stderr b/testsuite/tests/generics/T5462No1.stderr new file mode 100644 index 0000000000..9deb08a9f9 --- /dev/null +++ b/testsuite/tests/generics/T5462No1.stderr @@ -0,0 +1,20 @@ +[1 of 2] Compiling GFunctor ( GFunctor/GFunctor.hs, GFunctor/GFunctor.o ) +[2 of 2] Compiling T5462No1 ( T5462No1.hs, T5462No1.o ) + +T5462No1.hs:24:42: + Can't make a derived instance of ‘GFunctor F’: + ‘GFunctor’ is not a derivable class + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for ‘F’ + +T5462No1.hs:26:23: + Can't make a derived instance of ‘C1 G’: + ‘C1’ is not a derivable class + Try enabling DeriveAnyClass + In the data declaration for ‘G’ + +T5462No1.hs:27:23: + Can't make a derived instance of ‘C2 H’: + ‘C2’ is not a derivable class + Try enabling DeriveAnyClass + In the data declaration for ‘H’ diff --git a/testsuite/tests/generics/T5462Yes1.hs b/testsuite/tests/generics/T5462Yes1.hs new file mode 100644 index 0000000000..35785295d6 --- /dev/null +++ b/testsuite/tests/generics/T5462Yes1.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Main where + +import GHC.Generics hiding (C, C1, D) +import GEq1A +import Enum +import GFunctor + +data A = A1 + deriving (Show, Generic, GEq, GEnum) + +data B a = B1 | B2 a (B a) + deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor) + +data C phantom a = C1 | C2 a (C phantom a) + deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor) + +data D f a = D1 (f a) (f (D f a)) deriving (Generic, Generic1) +deriving instance (Show (f a), Show (f (D f a))) => Show (D f a) +deriving instance (GEq (f a), GEq (f (D f a))) => GEq (D f a) + +data E f a = E1 (f a) + deriving (Show, Eq, Generic, Generic1, GFunctor) + + +main = print ( + geq A1 A1 + , take 10 (genum :: [A]) + + , geq (B2 A1 B1) B1 + , gmap (++ "lo") (B2 "hel" B1) + , take 3 (genum :: [B A]) + + , geq (C2 A1 C1) C1 + , gmap (++ "lo") (C2 "hel" C1) + + , geq (D1 "a" []) (D1 "a" []) + + , gmap (++ "lo") (E1 ["hel"]) + ) diff --git a/testsuite/tests/generics/T5462Yes1.stdout b/testsuite/tests/generics/T5462Yes1.stdout new file mode 100644 index 0000000000..6a2dc672a6 --- /dev/null +++ b/testsuite/tests/generics/T5462Yes1.stdout @@ -0,0 +1 @@ +(True,[A1],False,B2 "hello" B1,[B1,B2 A1 B1,B2 A1 (B2 A1 B1)],False,C2 "hello" C1,True,E1 ["hello"])
diff --git a/testsuite/tests/generics/T5462Yes2.hs b/testsuite/tests/generics/T5462Yes2.hs new file mode 100644 index 0000000000..9c222554aa --- /dev/null +++ b/testsuite/tests/generics/T5462Yes2.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Main where + +import GHC.Generics hiding (C, C1, D) +import GFunctor + +class C1 a where + c1 :: a -> Int + c1 _ = 1 + +class C2 a where + c21 :: a -> Int + c21 = c22 + c22 :: a -> Int + c22 = c21 + {-# MINIMAL c21 | c22 #-} + +newtype D = D Int deriving C1 + +instance C1 Int where c1 _ = 2 + +newtype F a = F1 [a] + deriving (Show, Eq, Generic, Generic1, GFunctor) + +data G = G1 deriving (C1) +data H = H1 deriving (C2) + + +main = print (c1 (D 3)) diff --git a/testsuite/tests/generics/T5462Yes2.stdout b/testsuite/tests/generics/T5462Yes2.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/generics/T5462Yes2.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T index df95fa604f..694f214633 100644 --- a/testsuite/tests/generics/all.T +++ b/testsuite/tests/generics/all.T @@ -19,11 +19,15 @@ test('GenCannotDoRep1_6', normal, compile_fail, ['']) test('GenCannotDoRep1_7', normal, compile_fail, ['']) test('GenCannotDoRep1_8', normal, compile_fail, ['']) -test('T5884', normal, compile, ['']) -test('GenNewtype', normal, compile_and_run, ['']) +test('T5462Yes1', normal, multimod_compile_and_run, ['T5462Yes1', '-iGEq -iGEnum -iGFunctor']) +test('T5462Yes2', normal, multimod_compile_and_run, ['T5462Yes2', '-iGFunctor']) +test('T5462No1', normal, multimod_compile_fail, ['T5462No1', '-iGFunctor']) -test('GenDerivOutput1_0', normal, compile, ['-dsuppress-uniques']) -test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques']) +test('T5884', normal, compile, ['']) +test('GenNewtype', normal, compile_and_run, ['']) + +test('GenDerivOutput1_0', normal, compile, ['-dsuppress-uniques']) +test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques']) test('T7878', extra_clean(['T7878A.o' ,'T7878A.hi' ,'T7878A.o-boot','T7878A.hi-boot' diff --git a/testsuite/tests/module/mod53.stderr b/testsuite/tests/module/mod53.stderr index 14ec2e2646..2630e9cc7c 100644 --- a/testsuite/tests/module/mod53.stderr +++ b/testsuite/tests/module/mod53.stderr @@ -2,4 +2,5 @@ mod53.hs:4:22: Can't make a derived instance of ‘C T’: ‘C’ is not a derivable class + Try enabling DeriveAnyClass In the data declaration for ‘T’ |