import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
- tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
+ tcLookupClass, tcLookupTyCon, tcLookupLocatedTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList )
import Inst ( getOverlapFlag )
import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
+import TypeRep ( PredType )
import RnBinds ( rnMethodBinds, rnTopBinds )
import RnEnv ( bindLocalNames )
import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConInstOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
import NameSet ( duDefs )
-import Kind ( splitKindFunTys )
+import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
- tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
+ tyConStupidTheta, isProductTyCon, isDataTyCon, isNewTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
- isUnLiftedType, mkClassPred, tyVarsOfType,
- isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
+ isUnLiftedType, mkClassPred, tyVarsOfType, tyVarsOfTypes,
+ isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
import Var ( TyVar, tyVarKind, varName )
-import VarSet ( mkVarSet, subVarSet )
+import VarSet ( mkVarSet, disjointVarSet )
import PrelNames
-import SrcLoc ( srcLocSpan, Located(..) )
+import SrcLoc ( SrcSpan, srcLocSpan, Located(..), unLoc )
import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
So, here are the synonyms for the ``equation'' structures:
\begin{code}
-type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
+type DerivEqn = (SrcSpan, InstOrigin, Name, Class, TyCon, [TyVar], DerivRhs)
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the RHS
-pprDerivEqn (n,c,tc,tvs,rhs)
- = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
+pprDerivEqn :: DerivEqn -> SDoc
+pprDerivEqn (l,_,n,c,tc,tvs,rhs)
+ = parens (hsep [ppr l, ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
type DerivRhs = ThetaType
type DerivSoln = DerivRhs
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
+ -> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM ([InstInfo], -- The generated "instance decls"
HsValBinds Name) -- Extra generated top-level bindings
-tcDeriving tycl_decls
+tcDeriving tycl_decls deriv_decls
= recoverM (returnM ([], emptyValBindsOut)) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
overlap_flag <- getOverlapFlag
- ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls
+ ; (ordinary_eqns, newtype_inst_info)
+ <- makeDerivEqns overlap_flag tycl_decls deriv_decls
; (ordinary_inst_info, deriv_binds)
<- extendLocalInstEnv (map iSpec newtype_inst_info) $
[See Appendix~E in the Haskell~1.2 report.] This code here deals w/
all those.
+Note [Newtype deriving superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'tys' here come from the partial application in the deriving
+clause. The last arg is the new instance type.
+
+We must pass the superclasses; the newtype might be an instance
+of them in a different way than the representation type
+E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
+Then the Show instance is not done via isomorphism; it shows
+ Foo 3 as "Foo 3"
+The Num instance is derived via isomorphism, but the Show superclass
+dictionary must the Show instance for Foo, *not* the Show dictionary
+gotten from the Num dictionary. So we must build a whole new dictionary
+not just use the Num one. The instance we want is something like:
+ instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
+ (+) = ((+)@a)
+ ...etc...
+There may be a coercion needed which we get from the tycon for the newtype
+when the dict is constructed in TcInstDcls.tcInstDecl2
+
+
\begin{code}
makeDerivEqns :: OverlapFlag
-> [LTyClDecl Name]
+ -> [LDerivDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
-makeDerivEqns overlap_flag tycl_decls
- = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
- returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
+makeDerivEqns overlap_flag tycl_decls deriv_decls
+ = do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes
+ (maybe_ordinaries, maybe_newtypes)
+ <- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level)
+ return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
- derive_these :: [(NewOrData, Name, LHsType Name)]
+ derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)]
-- Find the (nd, TyCon, Pred) pairs that must be `derived'
- derive_these = [ (nd, tycon, pred)
+ derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, nd, tycon, pred)
| L _ (TyData { tcdND = nd, tcdLName = L _ tycon,
tcdDerivs = Just preds }) <- tycl_decls,
pred <- preds ]
+ top_level_deriv :: LDerivDecl Name -> TcM (Maybe (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name))
+ top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $
+ do tycon <- tcLookupLocatedTyCon ty_name
+ let new_or_data = if isNewTyCon tycon then NewType else DataType
+ traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst))
+ return $ Just (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst)
+
------------------------------------------------------------------
- mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
+ -- takes (whether newtype or data, name of data type, partially applied type class)
+ mk_eqn :: (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
--
-- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign
-- we allow deriving (forall a. C [a]).
- mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
+ mk_eqn (loc, orig, new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
- setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
+ setSrcSpan loc $
addErrCtxt (derivCtxt tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
doptM Opt_GlasgowExts `thenM` \ gla_exts ->
- mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
+ mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
------------------------------------------------------------------
- -- data/newtype T a = ... deriving( C t1 t2 )
- -- leads to a call to mk_eqn_help with
- -- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
-
mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
| Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
= bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
| otherwise
- = do { eqn <- mkDataTypeEqn tycon clas
+ = do { eqn <- mkDataTypeEqn loc orig tycon clas
; returnM (Just eqn, Nothing) }
- mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys
+ mk_eqn_help loc orig gla_exts NewType tycon deriv_tvs clas tys
| can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
- = -- Go ahead and use the isomorphism
- traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_`
- new_dfun_name clas tycon `thenM` \ dfun_name ->
- returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
- iBinds = NewTypeDerived rep_tys }))
+ = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
+ ; -- Go ahead and use the isomorphism
+ dfun_name <- new_dfun_name clas tycon
+ ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
+ iBinds = NewTypeDerived ntd_info })) }
| std_class gla_exts clas
- = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
+ = mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
| otherwise -- Non-standard instance
= bale_out (if gla_exts then
non_std_err) -- Just complain about being a non-std instance
where
-- Here is the plan for newtype derivings. We see
- -- newtype T a1...an = T (t ak...an) deriving (.., C s1 .. sm, ...)
+ -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
-- where t is a type,
- -- ak...an is a suffix of a1..an
- -- ak...an do not occur free in t,
+ -- ak+1...an is a suffix of a1..an
+ -- ak+1...an do not occur free in t, nor in the s1..sm
-- (C s1 ... sm) is a *partial applications* of class C
-- with the last parameter missing
+ -- (T a1 .. ak) matches the kind of C's last argument
+ -- (and hence so does t)
+ --
+ -- We generate the instance
+ -- instance forall ({a1..ak} u fvs(s1..sm)).
+ -- C s1 .. sm t => C s1 .. sm (T a1...ak)
+ -- where T a1...ap is the partial application of
+ -- the LHS of the correct kind and p >= k
--
- -- We generate the instances
- -- instance C s1 .. sm (t ak...ap) => C s1 .. sm (T a1...ap)
- -- where T a1...ap is the partial application of the LHS of the correct kind
- -- and p >= k
+ -- NB: the variables below are:
+ -- tc_tvs = [a1, ..., an]
+ -- tyvars_to_keep = [a1, ..., ak]
+ -- rep_ty = t ak .. an
+ -- deriv_tvs = fvs(s1..sm) \ tc_tvs
+ -- tys = [s1, ..., sm]
+ -- rep_fn' = t
--
-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+ -- We generate the instance
-- instance Monad (ST s) => Monad (T s) where
- -- fail = coerce ... (fail @ ST s)
- -- (Actually we don't need the coerce, because non-rec newtypes are transparent
clas_tyvars = classTyVars clas
kind = tyVarKind (last clas_tyvars)
-- rep_pred is the representation dictionary, from where
-- we are gong to get all the methods for the newtype dictionary
- inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)])
- -- The 'tys' here come from the partial application
- -- in the deriving clause. The last arg is the new
- -- instance type.
-
- -- We must pass the superclasses; the newtype might be an instance
- -- of them in a different way than the representation type
- -- E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
- -- Then the Show instance is not done via isomorphism; it shows
- -- Foo 3 as "Foo 3"
- -- The Num instance is derived via isomorphism, but the Show superclass
- -- dictionary must the Show instance for Foo, *not* the Show dictionary
- -- gotten from the Num dictionary. So we must build a whole new dictionary
- -- not just use the Num one. The instance we want is something like:
- -- instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
- -- (+) = ((+)@a)
- -- ...etc...
- -- There's no 'corece' needed because after the type checker newtypes
- -- are transparent.
+ -- Next we figure out what superclass dictionaries to use
+ -- See Note [Newtype deriving superclasses] above
+ inst_tys = tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)]
sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys)
(classSCTheta clas)
-- If there are no tyvars, there's no need
-- to abstract over the dictionaries we need
- dict_tvs = deriv_tvs ++ tc_tvs
- dict_args | null dict_tvs = []
- | otherwise = rep_pred : sc_theta
+ -- Example: newtype T = MkT Int deriving( C )
+ -- We get the derived instance
+ -- instance C T
+ -- rather than
+ -- instance C Int => C T
+ dict_tvs = deriv_tvs ++ tyvars_to_keep
+ all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
+ (dict_args, ntd_info) | null dict_tvs = ([], Just all_preds)
+ | otherwise = (all_preds, Nothing)
-- Finally! Here's where we build the dictionary Id
- mk_inst_spec dfun_name
- = mkLocalInstance dfun overlap_flag
+ mk_inst_spec dfun_name = mkLocalInstance dfun overlap_flag
where
dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys
-- Check that eta reduction is OK
-- (a) the dropped-off args are identical
- -- (b) the remaining type args mention
- -- only the remaining type variables
+ -- (b) the remaining type args do not mention any of teh dropped type variables
+ -- (c) the type class args do not mention any of teh dropped type variables
+ dropped_tvs = mkVarSet tyvars_to_drop
eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
- && (tyVarsOfType rep_fn' `subVarSet` mkVarSet tyvars_to_keep)
+ && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
+ && (tyVarsOfTypes tys `disjointVarSet` dropped_tvs)
cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
(vcat [ptext SLIT("even with cunning newtype deriving:"),
-- a suitable string; hence the empty type arg list
------------------------------------------------------------------
-mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn
-mkDataTypeEqn tycon clas
+mkDataTypeEqn :: SrcSpan -> InstOrigin -> TyCon -> Class -> TcM DerivEqn
+mkDataTypeEqn loc orig tycon clas
| clas `hasKey` typeableClassKey
= -- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- Typeable; it depends on the arity of the type
do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
; dfun_name <- new_dfun_name real_clas tycon
- ; return (dfun_name, real_clas, tycon, [], []) }
+ ; return (loc, orig, dfun_name, real_clas, tycon, [], []) }
| otherwise
= do { dfun_name <- new_dfun_name clas tycon
- ; return (dfun_name, clas, tycon, tyvars, constraints) }
+ ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) }
where
tyvars = tyConTyVars tycon
constraints = extra_constraints ++ ordinary_constraints
-- (b) 7 or fewer args
cond_typeableOK (gla_exts, tycon)
| tyConArity tycon > 7 = Just too_many
- | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+ | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
| otherwise = Nothing
where
too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
iterateDeriv (n+1) new_solns
------------------------------------------------------------------
- gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ gen_soln :: DerivEqn -> TcM [PredType]
+ gen_soln (loc, orig, _, clas, tc,tyvars,deriv_rhs)
+ = setSrcSpan loc $
do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
- tcSimplifyDeriv tc tyvars deriv_rhs
+ tcSimplifyDeriv orig tc tyvars deriv_rhs
; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction
------------------------------------------------------------------
- mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
+ mk_inst_spec :: DerivEqn -> DerivSoln -> Instance
+ mk_inst_spec (loc, orig, dfun_name, clas, tycon, tyvars, _) theta
= mkLocalInstance dfun overlap_flag
where
dfun = mkDictFunId dfun_name tyvars theta clas
projects / ghc-hetmet.git / blobdiff