Commit 2f74be9c authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Fill in associated type defaults with DeriveAnyClass

Summary:
Unlike `-XDefaultSignatures`, `-XDeriveAnyClass` would not fill in
associated type family defaults when deriving a class which contained
them.

In order to fix this properly, `tcATDefault` needed to be used from
`TcGenDeriv`. To avoid a module import cycle, `tcATDefault` was moved
from `TcInstDcls` to `TcClsDcl`.

Fixes #10361.

Test Plan: ./validate

Reviewers: kosmikus, dreixel, bgamari, austin, simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1283

GHC Trac Issues: #10361
parent 0eb8fcd9
......@@ -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)) }
......@@ -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).
************************************************************************
* *
......
......@@ -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)
......
......@@ -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
......
......@@ -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
~~~~~~~~
......
......@@ -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
......
{-# 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'
{-# 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)
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment