diff options
| -rw-r--r-- | compiler/typecheck/TcClassDcl.hs | 73 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 67 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 34 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 62 | ||||
| -rw-r--r-- | docs/users_guide/7.12.1-notes.rst | 3 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 46 | ||||
| -rw-r--r-- | testsuite/tests/generics/T10361a.hs | 32 | ||||
| -rw-r--r-- | testsuite/tests/generics/T10361b.hs | 58 | ||||
| -rw-r--r-- | testsuite/tests/generics/all.T | 2 |
9 files changed, 291 insertions, 86 deletions
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index bb4159a4be..2409b7b4e5 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -12,7 +12,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcClassMinimalDef, HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, - tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr + tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr, + tcATDefault ) where #include "HsVersions.h" @@ -30,13 +31,21 @@ import TcType import TcRnMonad import BuildTyCl( TcMethInfo ) import Class +import Coercion ( pprCoAxiom ) +import DynFlags +import FamInst +import FamInstEnv import Id import Name import NameEnv import NameSet import Var +import VarEnv +import VarSet import Outputable import SrcLoc +import TyCon +import TypeRep import Maybes import BasicTypes import Bag @@ -45,6 +54,7 @@ import BooleanFormula import Util import Control.Monad +import Data.List ( mapAccumL ) {- Dictionary handling @@ -418,3 +428,64 @@ warningMinimalDefIncomplete mindef = vcat [ ptext (sLit "The MINIMAL pragma does not require:") , nest 2 (pprBooleanFormulaNice mindef) , ptext (sLit "but there is no default implementation.") ] + +tcATDefault :: Bool -- If a warning should be emitted when a default instance + -- definition is not provided by the user + -> SrcSpan + -> TvSubst + -> NameSet + -> ClassATItem + -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instatiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTy subst' rhs_ty + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElemsKvsFirst tv_set' + ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' + fam_tc pat_tys' rhs' + -- NB: no validity check. We check validity of default instances + -- in the class definition. Because type instance arguments cannot + -- be type family applications and cannot be polytypes, the + -- validity check is redundant. + + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { when emit_warn $ warnMissingAT (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) + +warnMissingAT :: Name -> TcM () +warnMissingAT name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn) + ; warnTc warn -- Warn only if -fwarn-missing-methods + (ptext (sLit "No explicit") <+> text "associated type" + <+> ptext (sLit "or default declaration for ") + <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 2b1b77491e..05d689a203 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -19,7 +19,7 @@ import TcRnMonad import FamInst import TcErrors( reportAllUnsolved ) import TcValidity( validDerivPred ) -import TcClassDcl( tcMkDeclCtxt ) +import TcClassDcl( tcATDefault, tcMkDeclCtxt ) import TcEnv import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -52,6 +52,7 @@ import NameSet import TyCon import TcType import Var +import VarEnv import VarSet import PrelNames import THNames ( liftClassKey ) @@ -1986,6 +1987,7 @@ genInst comauxs | otherwise = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas dfun_name rep_tycon + tys tvs (lookupNameEnv comauxs (tyConName rep_tycon)) ; inst_spec <- newDerivClsInst theta spec @@ -2001,12 +2003,15 @@ genInst comauxs where rhs_ty = newTyConInstRhs rep_tycon rep_tc_args -genDerivStuff :: SrcSpan -> Class -> Name -> TyCon +-- Generate the bindings needed for a derived class that isn't handled by +-- -XGeneralizedNewtypeDeriving. +genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar] -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc clas dfun_name tycon comaux_maybe +genDerivStuff loc clas dfun_name tycon inst_tys tyvars comaux_maybe + -- Special case for DeriveGeneric | let ck = classKey clas - , -- Special case because monadic + , Just gk <- lookup ck [(genClassKey, Gen0), (gen1ClassKey, Gen1)] = let -- TODO NSF: correctly identify when we're building Both instead of One Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst @@ -2014,10 +2019,35 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) return (binds, unitBag (DerivFamInst faminst)) - | otherwise -- Non-monadic generators + -- Not deriving Generic(1), so we first check if the compiler has built-in + -- support for deriving the class in question. + | otherwise = do { dflags <- getDynFlags ; fix_env <- getDataConFixityFun tycon - ; return (genDerivedBinds dflags fix_env clas loc tycon) } + ; case hasBuiltinDeriving dflags fix_env clas of + Just gen_fn -> return (gen_fn loc tycon) + Nothing -> genDerivAnyClass dflags } + + where + genDerivAnyClass :: DynFlags -> TcM (LHsBinds RdrName, BagDerivStuff) + genDerivAnyClass dflags = + do { -- If there isn't compiler support for deriving the class, our last + -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving + -- fell through). + let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + + ; tyfam_insts <- + ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas) + , ppr "genDerivStuff: bad derived class" <+> ppr clas ) + mapM (tcATDefault False loc mini_subst emptyNameSet) + (classATItems clas) + ; return ( emptyBag -- No method bindings are needed... + , listToBag (map DerivFamInst (concat tyfam_insts)) + -- ...but we may need to generate binding for associated type + -- family default instances. + -- See Note [DeriveAnyClass and default family instances] + ) } getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) -- If the TyCon is locally defined, we want the local fixity env; @@ -2057,6 +2087,31 @@ representation type. See the paper "Safe zero-cost coercions for Hsakell". +Note [DeriveAnyClass and default family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When a class has a associated type family with a default instance, e.g.: + + class C a where + type T a + type T a = Char + +then there are a couple of scenarios in which a user would expect T a to +default to Char. One is when an instance declaration for C is given without +an implementation for T: + + instance C Int + +Another scenario in which this can occur is when the -XDeriveAnyClass extension +is used: + + data Example = Example deriving (C, Generic) + +In the latter case, we must take care to check if C has any associated type +families with default instances, because -XDeriveAnyClass will never provide +an implementation for them. We "fill in" the default instances using the +tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle +the empty instance declaration case). ************************************************************************ * * diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index b60fc8c032..eb9c00d16b 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -18,8 +18,7 @@ This is where we do all the grimy bindings' generation. module TcGenDeriv ( BagDerivStuff, DerivStuff(..), - canDeriveAnyClass, - genDerivedBinds, + hasBuiltinDeriving, canDeriveAnyClass, FFoldType(..), functorLikeTraverse, deepSubtypesContaining, foldDataConArgs, mkCoerceClassMethEqn, @@ -75,7 +74,6 @@ import StaticFlags( opt_PprStyle_Debug ) import ListSetOps ( assocMaybe ) import Data.List ( partition, intersperse ) -import Data.Maybe ( isNothing ) type BagDerivStuff = Bag DerivStuff @@ -101,26 +99,26 @@ data DerivStuff -- Please add this auxiliary stuff {- ************************************************************************ * * - Top level function + Class deriving diagnostics * * ************************************************************************ --} -genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon - -> ( LHsBinds RdrName -- The method bindings of the instance declaration - , BagDerivStuff) -- Specifies extra top-level declarations needed - -- to support the instance declaration -genDerivedBinds dflags fix_env clas loc tycon - | Just gen_fn <- assocMaybe gen_list (getUnique clas) - = gen_fn loc tycon +Only certain blessed classes can be used in a deriving clause. These classes +are listed below in the definition of hasBuiltinDeriving (with the exception +of Generic and Generic1, which are handled separately in TcGenGenerics). - | otherwise - -- 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) +A class might be able to be used in a deriving clause if it -XDeriveAnyClass +is willing to support it. The canDeriveAnyClass function checks if this is +the case. +-} +hasBuiltinDeriving :: DynFlags + -> (Name -> Fixity) + -> Class + -> Maybe (SrcSpan + -> TyCon + -> (LHsBinds RdrName, BagDerivStuff)) +hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas) where gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] gen_list = [ (eqClassKey, gen_Eq_binds) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index d5dee95b00..c97e4e128c 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -15,7 +15,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where import HsSyn import TcBinds import TcTyClsDecls -import TcClassDcl( tcClassDecl2, +import TcClassDcl( tcClassDecl2, tcATDefault, HsSigFun, lookupHsSig, mkHsSigFun, findMethodBind, instantiateMethod ) import TcPat ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv ) @@ -32,7 +32,6 @@ import TcDeriv import TcEnv import TcHsType import TcUnify -import Coercion ( pprCoAxiom {- , isReflCo, mkSymCo, mkSubCo -} ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -62,7 +61,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes -import Data.List ( mapAccumL, partition ) +import Data.List ( partition ) {- Typechecking instance declarations is done in two passes. The first @@ -537,7 +536,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) `unionNameSet` mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) - ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats) + ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats) (classATItems clas) -- Finally, construct the Core representation of the instance. @@ -559,51 +558,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , deriv_infos ) } -tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] --- ^ Construct default instances for any associated types that --- aren't given a user definition --- Returns [] or singleton -tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - = return [] - - -- No user instance, have defaults ==> instatiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) - rhs' = substTy subst' rhs_ty - tv_set' = tyVarsOfTypes pat_tys' - tvs' = varSetElemsKvsFirst tv_set' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' fam_tc pat_tys' rhs' - -- NB: no validity check. We check validity of default instances - -- in the class definition. Because type instance arguments cannot - -- be type family applications and cannot be polytypes, the - -- validity check is redundant. - - ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty - , pprCoAxiom axiom ]) - ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst axiom - ; return [fam_inst] } - - -- No defaults ==> generate a warning - | otherwise -- defs = Nothing - = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) - ; return [] } - where - subst_tv subst tc_tv - | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv - = (subst, ty) - | otherwise - = (extendTvSubst subst tc_tv ty', ty') - where - ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) - {- ************************************************************************ * * @@ -1576,16 +1530,6 @@ derivBindCtxt sel_id clas tys <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] -warnMissingMethodOrAT :: String -> Name -> TcM () -warnMissingMethodOrAT what name - = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name)))) - ; warnTc (warn -- Warn only if -fwarn-missing-methods - && not (startsWithUnderscore (getOccName name))) - -- Don't warn about _foo methods - (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for") - <+> quotes (ppr name)) } - warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst index dc87c59c9e..0e1d0a2563 100644 --- a/docs/users_guide/7.12.1-notes.rst +++ b/docs/users_guide/7.12.1-notes.rst @@ -78,6 +78,9 @@ Language arguments with certain unlifted types. See :ref:`generic-programming` for more details. +- The ``-XDeriveAnyClass`` extension now fills in associated type family + default instances when deriving a class that contains them. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index bc9e0233f3..59bbd2e16e 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -4118,11 +4118,53 @@ With ``-XDeriveAnyClass`` 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 ``Eq``. This is mostly useful in classes whose `minimal set <#minimal-pragma>`__ is -empty, and especially when writing `generic -functions <#generic-programming>`__. In case you try to derive some +empty, and especially when writing +`generic functions <#generic-programming>`__. In case you try to derive some class on a newtype, and ``-XGeneralizedNewtypeDeriving`` is also on, ``-XDeriveAnyClass`` takes precedence. +As an example, consider a simple pretty-printer class ``SPretty``, which outputs +pretty strings: :: + + {-# LANGUAGE DefaultSignatures, DeriveAnyClass #-} + + class SPretty a where + sPpr :: a -> String + default sPpr :: Show a => a -> String + sPpr = show + +If a user does not provide a manual implementation for ``sPpr``, then it will +default to ``show``. Now we can leverage the ``-XDeriveAnyClass`` extension to +easily implement a ``SPretty`` instance for a new data type: :: + + data Foo = Foo deriving (Show, SPretty) + +The above code is equivalent to: :: + + data Foo = Foo deriving Show + instance SPretty Foo + +That is, an ``SPretty Foo`` instance will be created with empty implementations +for all methods. Since we are using ``-XDefaultSignatures`` in this example, a +default implementation of ``sPpr`` is filled in automatically. + +Similarly, ``-XDeriveAnyClass`` can be used to fill in default instances for +associated type families: :: + + {-# LANGUAGE DeriveAnyClass, TypeFamilies #-} + + class Sizable a where + type Size a + type Size a = Int + + data Bar = Bar deriving Sizable + + doubleBarSize :: Size Bar -> Size Bar + doubleBarSize s = 2*s + +Since ``-XDeriveAnyClass`` does not generate an instance definition for ``Size +Bar``, it will default to ``Int``. + .. _type-class-extensions: Class and instances declarations diff --git a/testsuite/tests/generics/T10361a.hs b/testsuite/tests/generics/T10361a.hs new file mode 100644 index 0000000000..cc5fbb9dca --- /dev/null +++ b/testsuite/tests/generics/T10361a.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module T10361a where + +class C1 a where + type T1 a + type instance T1 a = Char + +class C2 a where -- equivalent to C1 + type T2 a + type instance T2 a = Char + +class C3 a where -- equivalent to C1, C2 + type T3 a + type instance T3 a = Char + +data A = B + deriving C1 + +deriving instance C2 A + +instance C3 A + +test1 :: T1 A +test1 = 'x' + +test2 :: T2 A +test2 = 'x' + +test3 :: T3 A +test3 = 'x' diff --git a/testsuite/tests/generics/T10361b.hs b/testsuite/tests/generics/T10361b.hs new file mode 100644 index 0000000000..6ecd99e644 --- /dev/null +++ b/testsuite/tests/generics/T10361b.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T10361b where + +import GHC.Generics + +--------------------------------------------------------------------- +class Convert a where + type Result a + type instance Result a = GResult (Rep a) + + convert :: a -> Result a + default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) + convert x = gconvert (from x) + +instance Convert Float where + type Result Float = Float + convert = id + +instance Convert Int where + type Result Int = Int + convert = id + +--------------------------------------------------------------------- +class GConvert f where + type GResult f + gconvert :: f p -> GResult f + +instance (Convert c) => GConvert (K1 i c) where + type GResult (K1 i c) = Result c + gconvert (K1 x) = convert x + +instance (GConvert f) => GConvert (M1 i t f) where + type GResult (M1 i t f) = GResult f + gconvert (M1 x) = gconvert x + +instance (GConvert f, GConvert g) => GConvert (f :*: g) where + type GResult (f :*: g) = (GResult f, GResult g) + gconvert (x :*: y) = (gconvert x, gconvert y) + +--------------------------------------------------------------------- + +data Data1 = Data1 Int Float + deriving (Generic) + +instance Convert Data1 + +val :: (Int, Float) +val = convert $ Data1 0 0.0 + +data Data2 = Data2 Int Float + deriving (Generic, Convert) diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T index 31a6809c82..cbf70cf8bf 100644 --- a/testsuite/tests/generics/all.T +++ b/testsuite/tests/generics/all.T @@ -40,3 +40,5 @@ test('T8468', normal, compile_fail, ['']) test('T8479', normal, compile, ['']) test('T9563', normal, compile, ['']) test('T10030', normal, compile_and_run, ['']) +test('T10361a', normal, compile, ['']) +test('T10361b', normal, compile, ['']) |