%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcInstDecls]{Typechecking instance declarations}
+
+TcInstDecls: Typechecking instance declarations
\begin{code}
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
-#include "HsVersions.h"
-
import HsSyn
-import TcBinds ( mkPragFun, tcPrags, badBootDeclErr )
-import TcTyClsDecls ( tcIdxTyInstDecl )
-import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, badATErr,
- omittedATWarn, tcClassDecl2, getGenericInstances )
-import TcRnMonad
-import TcMType ( tcSkolSigType, checkValidInstance,
- checkValidInstHead )
-import TcType ( TcType, mkClassPred, tcSplitSigmaTy,
- tcSplitDFunHead, SkolemInfo(InstSkol),
- tcSplitTyConApp,
- tcSplitDFunTy, mkFunTy )
-import Inst ( newDictBndr, newDictBndrs, instToId, showLIE,
- getOverlapFlag, tcExtendLocalInstEnv )
-import InstEnv ( mkLocalInstance, instanceDFunId )
-import FamInst ( tcExtendLocalFamInstEnv )
-import FamInstEnv ( extractFamInsts )
-import TcDeriv ( tcDeriving )
-import TcEnv ( InstInfo(..), InstBindings(..),
- newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
- )
-import TcHsType ( kcHsSigType, tcHsKindedType )
-import TcUnify ( checkSigTyVars )
-import TcSimplify ( tcSimplifySuperClasses )
-import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
- TyThing(ATyCon), isTyVarTy, tcEqType,
- substTys, emptyTvSubst, extendTvSubst )
-import Coercion ( mkSymCoercion )
-import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars,
- isTyConAssoc, tyConFamInst_maybe,
- assocTyConArgPoss_maybe )
-import DataCon ( classDataCon, dataConInstArgTys )
-import Class ( Class, classTyCon, classBigSig, classATs )
-import Var ( TyVar, Id, idName, idType, tyVarName )
-import MkId ( mkDictFunId )
-import Name ( Name, getSrcLoc, nameOccName )
-import NameSet ( addListToNameSet, emptyNameSet, minusNameSet,
- nameSetToList )
-import Maybe ( fromJust, catMaybes )
-import Monad ( when )
-import List ( find )
-import DynFlags ( DynFlag(Opt_WarnMissingMethods) )
-import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart,
- getLoc)
-import ListSetOps ( minusList )
-import Util ( snocView, dropList )
+import TcBinds
+import TcTyClsDecls
+import TcClassDcl
+import TcPat( addInlinePrags )
+import TcSimplify( simplifyTop )
+import TcRnMonad
+import TcMType
+import TcType
+import Inst
+import InstEnv
+import FamInst
+import FamInstEnv
+import MkCore ( nO_METHOD_BINDING_ERROR_ID )
+import TcDeriv
+import TcEnv
+import RnSource ( addTcgDUs )
+import TcHsType
+import TcUnify
+import Type
+import Coercion
+import TyCon
+import DataCon
+import Class
+import Var
+import VarSet
+import CoreUtils ( mkPiTypes )
+import CoreUnfold ( mkDFunUnfolding )
+import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr )
+import Id
+import MkId
+import Name
+import NameSet
+import DynFlags
+import SrcLoc
+import Util
import Outputable
import Bag
-import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
-import HscTypes ( implicitTyThings )
+import BasicTypes
+import HscTypes
import FastString
+import Maybes ( orElse )
+import Data.Maybe
+import Control.Monad
+import Data.List
+
+#include "HsVersions.h"
\end{code}
Typechecking instance declarations is done in two passes. The first
all the instance and value decls. Indeed that's the reason we need
two passes over the instance decls.
-Here is the overall algorithm.
-Assume that we have an instance declaration
-
- instance c => k (t tvs) where b
-
-\begin{enumerate}
-\item
-$LIE_c$ is the LIE for the context of class $c$
-\item
-$betas_bar$ is the free variables in the class method type, excluding the
- class variable
-\item
-$LIE_cop$ is the LIE constraining a particular class method
-\item
-$tau_cop$ is the tau type of a class method
-\item
-$LIE_i$ is the LIE for the context of instance $i$
-\item
-$X$ is the instance constructor tycon
-\item
-$gammas_bar$ is the set of type variables of the instance
-\item
-$LIE_iop$ is the LIE for a particular class method instance
-\item
-$tau_iop$ is the tau type for this instance of a class method
-\item
-$alpha$ is the class variable
-\item
-$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
-\item
-$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
-\end{enumerate}
-
-ToDo: Update the list above with names actually in the code.
-
-\begin{enumerate}
-\item
-First, make the LIEs for the class and instance contexts, which means
-instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
-and make LIElistI and LIEI.
-\item
-Then process each method in turn.
-\item
-order the instance methods according to the ordering of the class methods
-\item
-express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
-\item
-Create final dictionary function from bindings generated already
-\begin{pseudocode}
-df = lambda inst_tyvars
- lambda LIEI
- let Bop1
- Bop2
- ...
- Bopn
- and dbinds_super
- in <op1,op2,...,opn,sd1,...,sdm>
-\end{pseudocode}
-Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
-and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
-\end{enumerate}
+
+Note [How instance declarations are translated]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is how we translation instance declarations into Core
+
+Running example:
+ class C a where
+ op1, op2 :: Ix b => a -> b -> b
+ op2 = <dm-rhs>
+
+ instance C a => C [a]
+ {-# INLINE [2] op1 #-}
+ op1 = <rhs>
+===>
+ -- Method selectors
+ op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
+ op1 = ...
+ op2 = ...
+
+ -- Default methods get the 'self' dictionary as argument
+ -- so they can call other methods at the same type
+ -- Default methods get the same type as their method selector
+ $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
+ $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
+ -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
+ -- Note [Tricky type variable scoping]
+
+ -- A top-level definition for each instance method
+ -- Here op1_i, op2_i are the "instance method Ids"
+ -- The INLINE pragma comes from the user pragma
+ {-# INLINE [2] op1_i #-} -- From the instance decl bindings
+ op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+ op1_i = /\a. \(d:C a).
+ let this :: C [a]
+ this = df_i a d
+ -- Note [Subtle interaction of recursion and overlap]
+
+ local_op1 :: forall b. Ix b => [a] -> b -> b
+ local_op1 = <rhs>
+ -- Source code; run the type checker on this
+ -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
+ -- Note [Tricky type variable scoping]
+
+ in local_op1 a d
+
+ op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
+
+ -- The dictionary function itself
+ {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
+ df_i :: forall a. C a -> C [a]
+ df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
+ -- But see Note [Default methods in instances]
+ -- We can't apply the type checker to the default-method call
+
+ -- Use a RULE to short-circuit applications of the class ops
+ {-# RULE "op1@C[a]" forall a, d:C a.
+ op1 [a] (df_i d) = op1_i a d #-}
+
+Note [Instances and loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Note that df_i may be mutually recursive with both op1_i and op2_i.
+ It's crucial that df_i is not chosen as the loop breaker, even
+ though op1_i has a (user-specified) INLINE pragma.
+
+* Instead the idea is to inline df_i into op1_i, which may then select
+ methods from the MkC record, and thereby break the recursion with
+ df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
+ the same type, it won't mention df_i, so there won't be recursion in
+ the first place.)
+
+* If op1_i is marked INLINE by the user there's a danger that we won't
+ inline df_i in it, and that in turn means that (since it'll be a
+ loop-breaker because df_i isn't), op1_i will ironically never be
+ inlined. But this is OK: the recursion breaking happens by way of
+ a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
+ unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
+
+Note [ClassOp/DFun selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One thing we see a lot is stuff like
+ op2 (df d1 d2)
+where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
+'op2' and 'df' to get
+ case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
+ MkD _ op2 _ _ _ -> op2
+And that will reduce to ($cop2 d1 d2) which is what we wanted.
+
+But it's tricky to make this work in practice, because it requires us to
+inline both 'op2' and 'df'. But neither is keen to inline without having
+seen the other's result; and it's very easy to get code bloat (from the
+big intermediate) if you inline a bit too much.
+
+Instead we use a cunning trick.
+ * We arrange that 'df' and 'op2' NEVER inline.
+
+ * We arrange that 'df' is ALWAYS defined in the sylised form
+ df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
+
+ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
+ that lists its methods.
+
+ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
+ a suitable constructor application -- inlining df "on the fly" as it
+ were.
+
+ * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
+ iff its argument satisfies exprIsConApp_maybe. This is done in
+ MkId mkDictSelId
+
+ * We make 'df' CONLIKE, so that shared uses stil match; eg
+ let d = df d1 d2
+ in ...(op2 d)...(op1 d)...
+
+Note [Single-method classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the class has just one method (or, more accurately, just one element
+of {superclasses + methods}), then we use a different strategy.
+
+ class C a where op :: a -> a
+ instance C a => C [a] where op = <blah>
+
+We translate the class decl into a newtype, which just gives a
+top-level axiom. The "constructor" MkC expands to a cast, as does the
+class-op selector.
+
+ axiom Co:C a :: C a ~ (a->a)
+
+ op :: forall a. C a -> (a -> a)
+ op a d = d |> (Co:C a)
+
+ MkC :: forall a. (a->a) -> C a
+ MkC = /\a.\op. op |> (sym Co:C a)
+
+The clever RULE stuff doesn't work now, because ($df a d) isn't
+a constructor application, so exprIsConApp_maybe won't return
+Just <blah>.
+
+Instead, we simply rely on the fact that casts are cheap:
+
+ $df :: forall a. C a => C [a]
+ {-# INLINE df #} -- NB: INLINE this
+ $df = /\a. \d. MkC [a] ($cop_list a d)
+ = $cop_list |> forall a. C a -> (sym (Co:C [a]))
+
+ $cop_list :: forall a. C a => [a] -> [a]
+ $cop_list = <blah>
+
+So if we see
+ (op ($df a d))
+we'll inline 'op' and '$df', since both are simply casts, and
+good things happen.
+
+Why do we use this different strategy? Because otherwise we
+end up with non-inlined dictionaries that look like
+ $df = $cop |> blah
+which adds an extra indirection to every use, which seems stupid. See
+Trac #4138 for an example (although the regression reported there
+wasn't due to the indirction).
+
+There is an awkward wrinkle though: we want to be very
+careful when we have
+ instance C a => C [a] where
+ {-# INLINE op #-}
+ op = ...
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument). So we nust not eta-expand $df
+above. We ensure that this doesn't happen by putting an INLINE
+pragma on the dfun itself; after all, it ends up being just a cast.
+
+There is one more dark corner to the INLINE story, even more deeply
+buried. Consider this (Trac #3772):
+
+ class DeepSeq a => C a where
+ gen :: Int -> a
+
+ instance C a => C [a] where
+ gen n = ...
+
+ class DeepSeq a where
+ deepSeq :: a -> b -> b
+
+ instance DeepSeq a => DeepSeq [a] where
+ {-# INLINE deepSeq #-}
+ deepSeq xs b = foldr deepSeq b xs
+
+That gives rise to these defns:
+
+ $cdeepSeq :: DeepSeq a -> [a] -> b -> b
+ -- User INLINE( 3 args )!
+ $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
+
+ $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
+ -- DFun (with auto INLINE pragma)
+ $fDeepSeq[] a d = $cdeepSeq a d |> blah
+
+ $cp1 a d :: C a => DeepSep [a]
+ -- We don't want to eta-expand this, lest
+ -- $cdeepSeq gets inlined in it!
+ $cp1 a d = $fDeepSep[] a (scsel a d)
+
+ $fC[] :: C a => C [a]
+ -- Ordinary DFun
+ $fC[] a d = MkC ($cp1 a d) ($cgen a d)
+
+Here $cp1 is the code that generates the superclass for C [a]. The
+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
+and then $cdeepSeq will inline there, which is definitely wrong. Like
+on the dfun, we solve this by adding an INLINE pragma to $cp1.
+
+Note [Subtle interaction of recursion and overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+ class C a where { op1,op2 :: a -> a }
+ instance C a => C [a] where
+ op1 x = op2 x ++ op2 x
+ op2 x = ...
+ instance C [Int] where
+ ...
+
+When type-checking the C [a] instance, we need a C [a] dictionary (for
+the call of op2). If we look up in the instance environment, we find
+an overlap. And in *general* the right thing is to complain (see Note
+[Overlapping instances] in InstEnv). But in *this* case it's wrong to
+complain, because we just want to delegate to the op2 of this same
+instance.
+
+Why is this justified? Because we generate a (C [a]) constraint in
+a context in which 'a' cannot be instantiated to anything that matches
+other overlapping instances, or else we would not be excecuting this
+version of op1 in the first place.
+
+It might even be a bit disguised:
+
+ nullFail :: C [a] => [a] -> [a]
+ nullFail x = op2 x ++ op2 x
+
+ instance C a => C [a] where
+ op1 x = nullFail x
+
+Precisely this is used in package 'regex-base', module Context.hs.
+See the overlapping instances for RegexContext, and the fact that they
+call 'nullFail' just like the example above. The DoCon package also
+does the same thing; it shows up in module Fraction.hs
+
+Conclusion: when typechecking the methods in a C [a] instance, we want to
+treat the 'a' as an *existential* type variable, in the sense described
+by Note [Binding when looking up instances]. That is why isOverlappableTyVar
+responds True to an InstSkol, which is the kind of skolem we use in
+tcInstDecl2.
+
+
+Note [Tricky type variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our example
+ class C a where
+ op1, op2 :: Ix b => a -> b -> b
+ op2 = <dm-rhs>
+
+ instance C a => C [a]
+ {-# INLINE [2] op1 #-}
+ op1 = <rhs>
+
+note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
+in scope in <rhs>. In particular, we must make sure that 'b' is in
+scope when typechecking <dm-rhs>. This is achieved by subFunTys,
+which brings appropriate tyvars into scope. This happens for both
+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
+complained if 'b' is mentioned in <rhs>.
+
%************************************************************************
-%* *
+%* *
\subsection{Extracting instance decls}
-%* *
+%* *
%************************************************************************
Gather up the instance declarations from their various sources
\begin{code}
-tcInstDecls1 -- Deal with both source-code and imported instance decls
- :: [LTyClDecl Name] -- For deriving stuff
- -> [LInstDecl Name] -- Source code instance decls
- -> TcM (TcGblEnv, -- The full inst env
- [InstInfo], -- Source-code instance decls to process;
- -- contains all dfuns for this module
- HsValBinds Name) -- Supporting bindings for derived instances
-
-tcInstDecls1 tycl_decls inst_decls
+tcInstDecls1 -- Deal with both source-code and imported instance decls
+ :: [LTyClDecl Name] -- For deriving stuff
+ -> [LInstDecl Name] -- Source code instance decls
+ -> [LDerivDecl Name] -- Source code stand-alone deriving decls
+ -> TcM (TcGblEnv, -- The full inst env
+ [InstInfo Name], -- Source-code instance decls to process;
+ -- contains all dfuns for this module
+ HsValBinds Name) -- Supporting bindings for derived instances
+
+tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
- -- (they recover, so that we get more than one error each
- -- round)
-
- -- (1) Do class instance declarations and instances of indexed
- -- types
- ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
- ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
- ; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
-
- ; let { (local_infos,
- at_tycons) = unzip local_info_tycons
- ; local_info = concat local_infos
- ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons
- ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
- ; implicit_things = concatMap implicitTyThings at_idx_tycon
- }
-
- -- (2) Add the tycons of indexed types and their implicit
- -- tythings to the global environment
- ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
-
- -- (3) Instances from generic class declarations
+ -- (they recover, so that we get more than one error each
+ -- round)
+
+ -- (1) Do class and family instance declarations
+ ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+ filter (isFamInstDecl . unLoc) tycl_decls
+ ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
+
+ ; let { (local_info,
+ at_tycons_s) = unzip local_info_tycons
+ ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
+ ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
+ ; implicit_things = concatMap implicitTyThings at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons
+ }
+
+ -- (2) Add the tycons of indexed types and their implicit
+ -- tythings to the global environment
+ ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+
+ -- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
- -- Next, construct the instance environment so far, consisting
- -- of
- -- a) local instance decls
- -- b) generic instances
- -- c) local family instance decls
- ; addInsts local_info $ do {
- ; addInsts generic_inst_info $ do {
- ; addFamInsts at_idx_tycon $ do {
-
- -- (4) Compute instances from "deriving" clauses;
- -- This stuff computes a context for the derived instance
- -- decl, so it needs to know about all the instances possible
- ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
- ; addInsts deriv_inst_info $ do {
-
- ; gbl_env <- getGblEnv
- ; returnM (gbl_env,
- generic_inst_info ++ deriv_inst_info ++ local_info,
- deriv_binds)
- }}}}}}
- where
- -- Make sure that toplevel type instance are not for associated types.
- -- !!!TODO: Need to perform this check for the TyThing of type functions,
- -- too.
- tcIdxTyInstDeclTL ldecl@(L loc decl) =
- do { tything <- tcIdxTyInstDecl ldecl
- ; setSrcSpan loc $
- when (isAssocFamily tything) $
- addErr $ assocInClassErr (tcdName decl)
- ; return tything
- }
- isAssocFamily (Just (ATyCon tycon)) =
- case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
- isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
- isAssocFamily Nothing = False
-
-assocInClassErr name =
- ptext SLIT("Associated type") <+> quotes (ppr name) <+>
- ptext SLIT("must be inside a class instance")
-
-addInsts :: [InstInfo] -> TcM a -> TcM a
+ -- Next, construct the instance environment so far, consisting
+ -- of
+ -- (a) local instance decls
+ -- (b) generic instances
+ -- (c) local family instance decls
+ ; addInsts local_info $
+ addInsts generic_inst_info $
+ addFamInsts at_idx_tycons $ do {
+
+ -- (4) Compute instances from "deriving" clauses;
+ -- This stuff computes a context for the derived instance
+ -- decl, so it needs to know about all the instances possible
+ -- NB: class instance declarations can contain derivings as
+ -- part of associated data type declarations
+ failIfErrsM -- If the addInsts stuff gave any errors, don't
+ -- try the deriving stuff, becuase that may give
+ -- more errors still
+ ; (deriv_inst_info, deriv_binds, deriv_dus)
+ <- tcDeriving tycl_decls inst_decls deriv_decls
+ ; gbl_env <- addInsts deriv_inst_info getGblEnv
+ ; return ( addTcgDUs gbl_env deriv_dus,
+ generic_inst_info ++ deriv_inst_info ++ local_info,
+ aux_binds `plusHsValBinds` deriv_binds)
+ }}}
+
+addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside
-\end{code}
+ = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
+ where
+ mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
+ mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
+ (ppr tything)
+\end{code}
\begin{code}
-tcLocalInstDecl1 :: LInstDecl Name
- -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
- -- A source-file instance declaration
- -- Type-check all the stuff before the "where"
- --
- -- We check for respectable instance type, and context
-tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
- = -- Prime error recovery, set source location
- recoverM (returnM ([], [])) $
- setSrcSpan loc $
- addErrCtxt (instDeclCtxt1 poly_ty) $
-
- do { is_boot <- tcIsHsBoot
- ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
- badBootDeclErr
-
- -- Typecheck the instance type itself. We can't use
- -- tcHsSigType, because it's not a valid user type.
- ; kinded_ty <- kcHsSigType poly_ty
- ; poly_ty' <- tcHsKindedType kinded_ty
- ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
-
- -- Next, process any associated types.
- ; idx_tycons <- mappM tcIdxTyInstDecl ats
-
- -- Now, check the validity of the instance.
- ; (clas, inst_tys) <- checkValidInstHead tau
- ; checkValidInstance tyvars theta clas inst_tys
- ; checkValidAndMissingATs clas (tyvars, inst_tys)
- (zip ats idx_tycons)
-
- -- Finally, construct the Core representation of the instance.
- -- (This no longer includes the associated types.)
- ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
- ; overlap_flag <- getOverlapFlag
- ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
- ispec = mkLocalInstance dfun overlap_flag
-
- ; return ([InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags }],
- catMaybes idx_tycons)
+tcLocalInstDecl1 :: LInstDecl Name
+ -> TcM (InstInfo Name, [TyThing])
+ -- A source-file instance declaration
+ -- Type-check all the stuff before the "where"
+ --
+ -- We check for respectable instance type, and context
+tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
+ = setSrcSpan loc $
+ addErrCtxt (instDeclCtxt1 poly_ty) $
+
+ do { is_boot <- tcIsHsBoot
+ ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+ badBootDeclErr
+
+ ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
+ ; checkValidInstance poly_ty tyvars theta clas inst_tys
+
+ -- Next, process any associated types.
+ ; idx_tycons <- recoverM (return []) $
+ do { idx_tycons <- checkNoErrs $
+ mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
+ ; checkValidAndMissingATs clas (tyvars, inst_tys)
+ (zip ats idx_tycons)
+ ; return idx_tycons }
+
+ -- Finally, construct the Core representation of the instance.
+ -- (This no longer includes the associated types.)
+ ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
+ -- Dfun location is that of instance *header*
+ ; overlap_flag <- getOverlapFlag
+ ; let (eq_theta,dict_theta) = partition isEqPred theta
+ theta' = eq_theta ++ dict_theta
+ dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
+ ispec = mkLocalInstance dfun overlap_flag
+
+ ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
+ idx_tycons)
}
where
-- We pass in the source form and the type checked form of the ATs. We
-- really need the source form only to be able to produce more informative
-- error messages.
checkValidAndMissingATs :: Class
- -> ([TyVar], [TcType]) -- instance types
- -> [(LTyClDecl Name, -- source form of AT
- Maybe TyThing)] -- Core form of AT
- -> TcM ()
+ -> ([TyVar], [TcType]) -- instance types
+ -> [(LTyClDecl Name, -- source form of AT
+ TyThing)] -- Core form of AT
+ -> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
- -- instance.
- ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
- definedATs = listToNameSet . map (tcdName.unLoc.fst) $ ats
- omitted = classDefATs `minusNameSet` definedATs
- ; warn <- doptM Opt_WarnMissingMethods
- ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
-
- -- Ensure that all AT indexes that correspond to class parameters
- -- coincide with the types in the instance head. All remaining
- -- AT arguments must be variables. Also raise an error for any
- -- type instances that are not associated with this class.
- ; mapM_ (checkIndexes clas inst_tys) ats
- }
-
- checkIndexes _ _ (hsAT, Nothing) =
- return () -- skip, we already had an error here
- checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
+ -- instance.
+ ; let class_ats = map tyConName (classATs clas)
+ defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
+ omitted = filterOut (`elemNameSet` defined_ats) class_ats
+ ; warn <- doptM Opt_WarnMissingMethods
+ ; mapM_ (warnTc warn . omittedATWarn) omitted
+
+ -- Ensure that all AT indexes that correspond to class parameters
+ -- coincide with the types in the instance head. All remaining
+ -- AT arguments must be variables. Also raise an error for any
+ -- type instances that are not associated with this class.
+ ; mapM_ (checkIndexes clas inst_tys) ats
+ }
+
+ checkIndexes clas inst_tys (hsAT, ATyCon tycon)
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
- checkIndexes' clas inst_tys hsAT
- (tyConTyVars tycon,
- snd . fromJust . tyConFamInst_maybe $ tycon)
+ = checkIndexes' clas inst_tys hsAT
+ (tyConTyVars tycon,
+ snd . fromJust . tyConFamInst_maybe $ tycon)
checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
- in
- setSrcSpan (getLoc hsAT) $
- addErrCtxt (atInstCtxt atName) $
- case find ((atName ==) . tyConName) (classATs clas) of
- Nothing -> addErrTc $ badATErr clas atName -- not in this class
- Just atDecl ->
- case assocTyConArgPoss_maybe atDecl of
- Nothing -> panic "checkIndexes': AT has no args poss?!?"
- Just poss ->
-
- -- The following is tricky! We need to deal with three
- -- complications: (1) The AT possibly only uses a subset of
- -- the class parameters as indexes and those it uses may be in
- -- a different order; (2) the AT may have extra arguments,
- -- which must be type variables; and (3) variables in AT and
- -- instance head will be different `Name's even if their
- -- source lexemes are identical.
+ in
+ setSrcSpan (getLoc hsAT) $
+ addErrCtxt (atInstCtxt atName) $
+ case find ((atName ==) . tyConName) (classATs clas) of
+ Nothing -> addErrTc $ badATErr clas atName -- not in this class
+ Just atycon ->
+ -- The following is tricky! We need to deal with three
+ -- complications: (1) The AT possibly only uses a subset of
+ -- the class parameters as indexes and those it uses may be in
+ -- a different order; (2) the AT may have extra arguments,
+ -- which must be type variables; and (3) variables in AT and
+ -- instance head will be different `Name's even if their
+ -- source lexemes are identical.
--
- -- Re (1), `poss' contains a permutation vector to extract the
- -- class parameters in the right order.
- --
- -- Re (2), we wrap the (permuted) class parameters in a Maybe
- -- type and use Nothing for any extra AT arguments. (First
- -- equation of `checkIndex' below.)
- --
- -- Re (3), we replace any type variable in the AT parameters
- -- that has the same source lexeme as some variable in the
- -- instance types with the instance type variable sharing its
- -- source lexeme.
- --
- let relevantInstTys = map (instTys !!) poss
- instArgs = map Just relevantInstTys ++
- repeat Nothing -- extra arguments
- renaming = substSameTyVar atTvs instTvs
- in
- zipWithM_ checkIndex (substTys renaming atTys) instArgs
-
- checkIndex ty Nothing
+ -- e.g. class C a b c where
+ -- data D b a :: * -> * -- NB (1) b a, omits c
+ -- instance C [x] Bool Char where
+ -- data D Bool [x] v = MkD x [v] -- NB (2) v
+ -- -- NB (3) the x in 'instance C...' have differnt
+ -- -- Names to x's in 'data D...'
+ --
+ -- Re (1), `poss' contains a permutation vector to extract the
+ -- class parameters in the right order.
+ --
+ -- Re (2), we wrap the (permuted) class parameters in a Maybe
+ -- type and use Nothing for any extra AT arguments. (First
+ -- equation of `checkIndex' below.)
+ --
+ -- Re (3), we replace any type variable in the AT parameters
+ -- that has the same source lexeme as some variable in the
+ -- instance types with the instance type variable sharing its
+ -- source lexeme.
+ --
+ let poss :: [Int]
+ -- For *associated* type families, gives the position
+ -- of that 'TyVar' in the class argument list (0-indexed)
+ -- e.g. class C a b c where { type F c a :: *->* }
+ -- Then we get Just [2,0]
+ poss = catMaybes [ tv `elemIndex` classTyVars clas
+ | tv <- tyConTyVars atycon]
+ -- We will get Nothings for the "extra" type
+ -- variables in an associated data type
+ -- e.g. class C a where { data D a :: *->* }
+ -- here D gets arity 2 and has two tyvars
+
+ relevantInstTys = map (instTys !!) poss
+ instArgs = map Just relevantInstTys ++
+ repeat Nothing -- extra arguments
+ renaming = substSameTyVar atTvs instTvs
+ in
+ zipWithM_ checkIndex (substTys renaming atTys) instArgs
+
+ checkIndex ty Nothing
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
- checkIndex ty (Just instTy)
+ checkIndex ty (Just instTy)
| ty `tcEqType` instTy = return ()
| otherwise = addErrTc $ wrongATArgErr ty instTy
- listToNameSet = addListToNameSet emptyNameSet
+ listToNameSet = addListToNameSet emptyNameSet
substSameTyVar [] _ = emptyTvSubst
- substSameTyVar (tv:tvs) replacingTvs =
+ substSameTyVar (tv:tvs) replacingTvs =
let replacement = case find (tv `sameLexeme`) replacingTvs of
- Nothing -> mkTyVarTy tv
- Just rtv -> mkTyVarTy rtv
+ Nothing -> mkTyVarTy tv
+ Just rtv -> mkTyVarTy rtv
--
- tv1 `sameLexeme` tv2 =
- nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
+ tv1 `sameLexeme` tv2 =
+ nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
\end{code}
%************************************************************************
-%* *
-\subsection{Type-checking instance declarations, pass 2}
-%* *
+%* *
+ Type-checking instance declarations, pass 2
+%* *
%************************************************************************
\begin{code}
-tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
- -> TcM (LHsBinds Id, TcLclEnv)
--- (a) From each class declaration,
--- generate any default-method bindings
+tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
+ -> TcM (LHsBinds Id)
+-- (a) From each class declaration,
+-- generate any default-method bindings
-- (b) From each instance decl
--- generate the dfun binding
+-- generate the dfun binding
tcInstDecls2 tycl_decls inst_decls
- = do { -- (a) Default methods from class decls
- (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
- filter (isClassDecl.unLoc) tycl_decls
- ; tcExtendIdEnv (concat dm_ids_s) $ do
-
- -- (b) instance declarations
- ; inst_binds_s <- mappM tcInstDecl2 inst_decls
-
- -- Done
- ; let binds = unionManyBags dm_binds_s `unionBags`
- unionManyBags inst_binds_s
- ; tcl_env <- getLclEnv -- Default method Ids in here
- ; returnM (binds, tcl_env) }
+ = do { -- (a) Default methods from class decls
+ let class_decls = filter (isClassDecl . unLoc) tycl_decls
+ ; dm_binds_s <- mapM tcClassDecl2 class_decls
+ ; let dm_binds = unionManyBags dm_binds_s
+
+ -- (b) instance declarations
+ ; let dm_ids = collectHsBindsBinders dm_binds
+ -- Add the default method Ids (again)
+ -- See Note [Default methods and instances]
+ ; inst_binds_s <- tcExtendIdEnv dm_ids $
+ mapM tcInstDecl2 inst_decls
+
+ -- Done
+ ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
\end{code}
-======= New documentation starts here (Sept 92) ==============
-
-The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
-the dictionary function for this instance declaration. For example
-\begin{verbatim}
- instance Foo a => Foo [a] where
- op1 x = ...
- op2 y = ...
-\end{verbatim}
-might generate something like
-\begin{verbatim}
- dfun.Foo.List dFoo_a = let op1 x = ...
- op2 y = ...
- in
- Dict [op1, op2]
-\end{verbatim}
-
-HOWEVER, if the instance decl has no context, then it returns a
-bigger @HsBinds@ with declarations for each method. For example
-\begin{verbatim}
- instance Foo [a] where
- op1 x = ...
- op2 y = ...
-\end{verbatim}
-might produce
-\begin{verbatim}
- dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
- const.Foo.op1.List a x = ...
- const.Foo.op2.List a y = ...
-\end{verbatim}
-This group may be mutually recursive, because (for example) there may
-be no method supplied for op2 in which case we'll get
-\begin{verbatim}
- const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
-\end{verbatim}
-that is, the default method applied to the dictionary at this type.
-
-What we actually produce in either case is:
-
- AbsBinds [a] [dfun_theta_dicts]
- [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
- { d = (sd1,sd2, ..., op1, op2, ...)
- op1 = ...
- op2 = ...
- }
-
-The "maybe" says that we only ask AbsBinds to make global constant methods
-if the dfun_theta is empty.
-
-
-For an instance declaration, say,
-
- instance (C1 a, C2 b) => C (T a b) where
- ...
-
-where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
-function whose type is
-
- (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
-
-Notice that we pass it the superclass dictionaries at the instance type; this
-is the ``Mark Jones optimisation''. The stuff before the "=>" here
-is the @dfun_theta@ below.
-
-First comes the easy case of a non-local instance decl.
+See Note [Default methods and instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
+don't have their InlinePragmas yet. Usually that would not matter,
+because the simplifier propagates information from binding site to
+use. But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
+
+So right here in tcInstDecl2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas. Urk.
+\begin{code}
+
+tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
+ -- Returns a binding for the dfun
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
+ = recoverM (return emptyLHsBinds) $
+ setSrcSpan loc $
+ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
+ do { -- Instantiate the instance decl with skolem constants
+ ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
+ ; let (clas, inst_tys) = tcSplitDFunHead inst_head
+ (class_tyvars, sc_theta, _, op_items) = classBigSig clas
+ sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
+ n_ty_args = length inst_tyvars
+ n_silent = dfunNSilent dfun_id
+ (silent_theta, orig_theta) = splitAt n_silent dfun_theta
+
+ ; silent_ev_vars <- mapM newSilentGiven silent_theta
+ ; orig_ev_vars <- newEvVars orig_theta
+ ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
+
+ ; (sc_binds, sc_dicts, sc_args)
+ <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
+
+ -- Check that any superclasses gotten from a silent arguemnt
+ -- can be deduced from the originally-specified dfun arguments
+ ; ct_loc <- getCtLoc ScOrigin
+ ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
+ emitConstraints $ listToBag $
+ [ WcEvVar (WantedEvVar sc ct_loc)
+ | sc <- sc_dicts, isSilentEvVar sc ]
+
+ -- Deal with 'SPECIALISE instance' pragmas
+ -- See Note [SPECIALISE instance pragmas]
+ ; spec_info <- tcSpecInstPrags dfun_id ibinds
+
+ -- Typecheck the methods
+ ; (meth_ids, meth_binds)
+ <- tcExtendTyVarEnv inst_tyvars $
+ -- The inst_tyvars scope over the 'where' part
+ -- Those tyvars are inside the dfun_id's type, which is a bit
+ -- bizarre, but OK so long as you realise it!
+ tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
+ inst_tys spec_info
+ op_items ibinds
+
+ -- Create the result bindings
+ ; self_dict <- newEvVar (ClassP clas inst_tys)
+ ; let class_tc = classTyCon clas
+ [dict_constr] = tyConDataCons class_tc
+ dict_bind = mkVarBind self_dict dict_rhs
+ dict_rhs = foldl mk_app inst_constr $
+ map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
+ inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
+ (dataConWrapId dict_constr)
+ -- We don't produce a binding for the dict_constr; instead we
+ -- rely on the simplifier to unfold this saturated application
+ -- We do this rather than generate an HsCon directly, because
+ -- it means that the special cases (e.g. dictionary with only one
+ -- member) are dealt with by the common MkId.mkDataConWrapId
+ -- code rather than needing to be repeated here.
+
+ mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
+ mk_app fun arg = L loc (HsApp fun (L loc arg))
+
+ arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
+
+ -- Do not inline the dfun; instead give it a magic DFunFunfolding
+ -- See Note [ClassOp/DFun selection]
+ -- See also note [Single-method classes]
+ dfun_id_w_fun
+ | isNewTyCon class_tc
+ = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+ | otherwise
+ = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
+ `setInlinePragma` dfunInlinePragma
+ meth_args = map (DFunPolyArg . Var) meth_ids
+
+ main_bind = AbsBinds { abs_tvs = inst_tyvars
+ , abs_ev_vars = dfun_ev_vars
+ , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
+ SpecPrags [] {- spec_inst_prags -})]
+ , abs_ev_binds = emptyTcEvBinds
+ , abs_binds = unitBag dict_bind }
+
+ ; return (unitBag (L loc main_bind) `unionBags`
+ unionManyBags sc_binds `unionBags`
+ listToBag meth_binds)
+ }
+ where
+ skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
+ dfun_ty = idType dfun_id
+ dfun_id = instanceDFunId ispec
+ loc = getSrcSpan dfun_id
+
+------------------------------
+tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
+tcSuperClass n_ty_args ev_vars pred
+ | Just (ev, i) <- find n_ty_args ev_vars
+ = return (emptyBag, ev, DFunLamArg i)
+ | otherwise
+ = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
+ do { sc_dict <- newWantedEvVar pred
+ ; loc <- getCtLoc ScOrigin
+ ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
+ ; let ev_wrap = WpLet (EvBinds ev_binds)
+ sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
+ ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
+ -- It's very important to solve the superclass constraint *in isolation*
+ -- so that it isn't generated by superclass selection from something else
+ -- We then generate the (also rather degenerate) top-level binding:
+ -- sc_dict = let sc_dict = <blah> in sc_dict
+ -- where <blah> is generated by solving the implication constraint
+ where
+ find _ [] = Nothing
+ find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
+ | otherwise = find (i+1) evs
+
+------------------------------
+tcSpecInstPrags :: DFunId -> InstBindings Name
+ -> TcM ([Located TcSpecPrag], PragFun)
+tcSpecInstPrags _ (NewTypeDerived {})
+ = return ([], \_ -> [])
+tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
+ = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+ filter isSpecInstLSig uprags
+ -- The filter removes the pragmas for methods
+ ; return (spec_inst_prags, mkPragFun uprags binds) }
+\end{code}
+
+Note [Silent Superclass Arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following (extreme) situation:
+ class C a => D a where ...
+ instance D [a] => D [a] where ...
+Although this looks wrong (assume D [a] to prove D [a]), it is only a
+more extreme case of what happens with recursive dictionaries.
+
+To implement the dfun we must generate code for the superclass C [a],
+which we can get by superclass selection from the supplied argument!
+So we’d generate:
+ dfun :: forall a. D [a] -> D [a]
+ dfun = \d::D [a] -> MkD (scsel d) ..
+
+However this means that if we later encounter a situation where
+we have a [Wanted] dw::D [a] we could solve it thus:
+ dw := dfun dw
+Although recursive, this binding would pass the TcSMonadisGoodRecEv
+check because it appears as guarded. But in reality, it will make a
+bottom superclass. The trouble is that isGoodRecEv can't "see" the
+superclass-selection inside dfun.
+
+Our solution to this problem is to change the way ‘dfuns’ are created
+for instances, so that we pass as first arguments to the dfun some
+``silent superclass arguments’’, which are the immediate superclasses
+of the dictionary we are trying to construct. In our example:
+ dfun :: forall a. (C [a], D [a] -> D [a]
+ dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
+
+This gives us:
+
+ -----------------------------------------------------------
+ DFun Superclass Invariant
+ ~~~~~~~~~~~~~~~~~~~~~~~~
+ In the body of a DFun, every superclass argument to the
+ returned dictionary is
+ either * one of the arguments of the DFun,
+ or * constant, bound at top level
+ -----------------------------------------------------------
+
+This means that no superclass is hidden inside a dfun application, so
+the counting argument in isGoodRecEv (more dfun calls than superclass
+selections) works correctly.
+
+The extra arguments required to satisfy the DFun Superclass Invariant
+always come first, and are called the "silent" arguments. DFun types
+are built (only) by MkId.mkDictFunId, so that is where we decide
+what silent arguments are to be added.
+
+This net effect is that it is safe to treat a dfun application as
+wrapping a dictionary constructor around its arguments (in particular,
+a dfun never picks superclasses from the arguments under the dictionary
+constructor).
+
+In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
+ dw := dfun d1 d2
+ [Wanted] (d1 :: C [a])
+ [Wanted] (d2 :: D [a])
+ [Derived] (d :: D [a])
+ [Derived] (scd :: C [a]) scd := scsel d
+ [Derived] (scd2 :: C [a]) scd2 := scsel d2
+
+And now, though we *can* solve:
+ d2 := dw
+we will get an isGoodRecEv failure when we try to solve:
+ d1 := scsel d
+ or
+ d1 := scsel d2
+
+Test case SCLoop tests this fix.
+
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ instance (Ix a, Ix b) => Ix (a,b) where
+ {-# SPECIALISE instance Ix (Int,Int) #-}
+ range (x,y) = ...
+
+We do *not* want to make a specialised version of the dictionary
+function. Rather, we want specialised versions of each method.
+Thus we should generate something like this:
+
+ $dfIx :: (Ix a, Ix x) => Ix (a,b)
+ {- DFUN [$crange, ...] -}
+ $dfIx da db = Ix ($crange da db) (...other methods...)
+
+ $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
+ {- DFUN [$crangePair, ...] -}
+ $dfIxPair = Ix ($crangePair da db) (...other methods...)
+
+ $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+ {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+ $crange da db = <blah>
+
+ {-# RULE range ($dfIx da db) = $crange da db #-}
+
+Note that
+
+ * The RULE is unaffected by the specialisation. We don't want to
+ specialise $dfIx, because then it would need a specialised RULE
+ which is a pain. The single RULE works fine at all specialisations.
+ See Note [How instance declarations are translated] above
+
+ * Instead, we want to specialise the *method*, $crange
+
+In practice, rather than faking up a SPECIALISE pragama for each
+method (which is painful, since we'd have to figure out its
+specialised type), we call tcSpecPrag *as if* were going to specialise
+$dfIx -- you can see that in the call to tcSpecInst. That generates a
+SpecPrag which, as it turns out, can be used unchanged for each method.
+The "it turns out" bit is delicate, but it works fine!
\begin{code}
-tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
--- Returns a binding for the dfun
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
+ = addErrCtxt (spec_ctxt prag) $
+ do { let name = idName dfun_id
+ ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
+ ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
+
+ ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
+ (idType dfun_id) spec_dfun_ty
+ ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
+ where
+ spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+
+tcSpecInst _ _ = panic "tcSpecInst"
+\end{code}
-------------------------
--- Derived newtype instances
+%************************************************************************
+%* *
+ Type-checking an instance method
+%* *
+%************************************************************************
+
+tcInstanceMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
+
+\begin{code}
+tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
+ -> [EvVar]
+ -> [TcType]
+ -> ([Located TcSpecPrag], PragFun)
+ -> [(Id, DefMeth)]
+ -> InstBindings Name
+ -> TcM ([Id], [LHsBind Id])
+ -- The returned inst_meth_ids all have types starting
+ -- forall tvs. theta => ...
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+ (spec_inst_prags, prag_fn)
+ op_items (VanillaInst binds _ standalone_deriv)
+ = mapAndUnzipM tc_item op_items
+ where
+ ----------------------
+ tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
+ tc_item (sel_id, dm_info)
+ = case findMethodBind (idName sel_id) binds of
+ Just user_bind -> tc_body sel_id standalone_deriv user_bind
+ Nothing -> tc_default sel_id dm_info
+
+ ----------------------
+ tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
+ tc_body sel_id generated_code rn_bind
+ = add_meth_ctxt sel_id generated_code rn_bind $
+ do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; let prags = prag_fn (idName sel_id)
+ ; meth_id1 <- addInlinePrags meth_id prags
+ ; spec_prags <- tcSpecPrags meth_id1 prags
+ ; bind <- tcInstanceMethodBody InstSkol
+ tyvars dfun_ev_vars
+ meth_id1 local_meth_id meth_sig_fn
+ (mk_meth_spec_prags meth_id1 spec_prags)
+ rn_bind
+ ; return (meth_id1, bind) }
+
+ ----------------------
+ tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+ tc_default sel_id GenDefMeth -- Derivable type classes stuff
+ = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
+ ; tc_body sel_id False {- Not generated code? -} meth_bind }
+
+ tc_default sel_id NoDefMeth -- No default method at all
+ = do { warnMissingMethod sel_id
+ ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; return (meth_id, mkVarBind meth_id $
+ mkLHsWrap lam_wrapper error_rhs) }
+ where
+ error_rhs = L loc $ HsApp error_fun error_msg
+ error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
+ error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+ meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
+ error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+ lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+ tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
+ = do { -- Build the typechecked version directly,
+ -- without calling typecheck_method;
+ -- see Note [Default methods in instances]
+ -- Generate /\as.\ds. let self = df as ds
+ -- in $dm inst_tys self
+ -- The 'let' is necessary only because HsSyn doesn't allow
+ -- you to apply a function to a dictionary *expression*.
+
+ ; self_dict <- newEvVar (ClassP clas inst_tys)
+ ; let self_ev_bind = EvBind self_dict $
+ EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
+
+ ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; dm_id <- tcLookupId dm_name
+ ; let dm_inline_prag = idInlinePragma dm_id
+ rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
+ HsVar dm_id
+
+ meth_bind = L loc $ VarBind { var_id = local_meth_id
+ , var_rhs = L loc rhs
+ , var_inline = False }
+ meth_id1 = meth_id `setInlinePragma` dm_inline_prag
+ -- Copy the inline pragma (if any) from the default
+ -- method to this version. Note [INLINE and default methods]
+
+ bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+ , abs_exports = [( tyvars, meth_id1, local_meth_id
+ , mk_meth_spec_prags meth_id1 [])]
+ , abs_ev_binds = EvBinds (unitBag self_ev_bind)
+ , abs_binds = unitBag meth_bind }
+ -- Default methods in an instance declaration can't have their own
+ -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
+ -- currently they are rejected with
+ -- "INLINE pragma lacks an accompanying binding"
+
+ ; return (meth_id1, L loc bind) }
+
+ ----------------------
+ mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
+ -- Adapt the SPECIALISE pragmas to work for this method Id
+ -- There are two sources:
+ -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
+ -- These ones have the dfun inside, but [perhaps surprisingly]
+ -- the correct wrapper
+ -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+ mk_meth_spec_prags meth_id spec_prags_for_me
+ = SpecPrags (spec_prags_for_me ++
+ [ L loc (SpecPrag meth_id wrap inl)
+ | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
+
+ loc = getSrcSpan dfun_id
+ meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
+ -- But there are no scoped type variables from local_method_id
+ -- Only the ones from the instance decl itself, which are already
+ -- in scope. Example:
+ -- class C a where { op :: forall b. Eq b => ... }
+ -- instance C [c] where { op = <rhs> }
+ -- In <rhs>, 'c' is scope but 'b' is not!
+
+ -- For instance decls that come from standalone deriving clauses
+ -- we want to print out the full source code if there's an error
+ -- because otherwise the user won't see the code at all
+ add_meth_ctxt sel_id generated_code rn_bind thing
+ | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
+ | otherwise = thing
+
+
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+ _ op_items (NewTypeDerived coi _)
+
+-- Running example:
+-- class Show b => Foo a b where
+-- op :: a -> b -> b
+-- newtype N a = MkN (Tree [a])
+-- deriving instance (Show p, Foo Int p) => Foo Int (N p)
+-- -- NB: standalone deriving clause means
+-- -- that the contex is user-specified
+-- Hence op :: forall a b. Foo a b => a -> b -> b
--
--- In the case of a newtype, things are rather easy
--- class Show a => Foo a b where ...
--- newtype T a = MkT (Tree [a]) deriving( Foo Int )
--- The newtype gives an FC axiom looking like
--- axiom CoT a :: T a :=: Tree [a]
--- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
+-- We're going to make an instance like
+-- instance (Show p, Foo Int p) => Foo Int (N p)
+-- op = $copT
--
--- So all need is to generate a binding looking like:
--- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
--- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
--- case df `cast` (Foo Int (sym (CoT a))) of
--- Foo _ op1 .. opn -> Foo ds op1 .. opn
+-- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
+-- $copT p (d1:Show p) (d2:Foo Int p)
+-- = op Int (Tree [p]) rep_d |> op_co
+-- where
+-- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
+-- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
+-- We get op_co by substituting [Int/a] and [co/b] in type for op
+-- where co : [p] ~ T p
--
--- If there are no superclasses, matters are simpler, because we don't need the case
--- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
- = do { let dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
- origin = SigOrigin rigid_info
- inst_ty = idType dfun_id
- ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
- -- inst_head_ty is a PredType
-
- ; inst_loc <- getInstLoc origin
- ; (rep_dict_id : sc_dict_ids, wrap_fn)
- <- make_wrapper inst_loc tvs theta mb_preds
- -- Here, we are relying on the order of dictionary
- -- arguments built by NewTypeDerived in TcDeriv;
- -- namely, that the rep_dict_id comes first
-
- ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
- the_coercion = make_coercion cls cls_inst_tys
- coerced_rep_dict = mkHsCoerce the_coercion (HsVar rep_dict_id)
-
- ; body <- make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict
-
- ; return (unitBag (noLoc $ VarBind dfun_id $ noLoc $ mkHsCoerce wrap_fn body)) }
+-- Notice that the dictionary bindings "..d1..d2.." must be generated
+-- by the constraint solver, since the <context> may be
+-- user-specified.
+
+ = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
+ emitWanted ScOrigin rep_pred
+
+ ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
+ where
+ loc = getSrcSpan dfun_id
+
+ inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
+ Just (init_inst_tys, _) = snocView inst_tys
+ rep_ty = fst (coercionKind co) -- [p]
+ rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
+
+ -- co : [p] ~ T p
+ co = substTyWith inst_tvs (mkTyVarTys tyvars) $
+ case coi of { IdCo ty -> ty ;
+ ACo co -> mkSymCoercion co }
+
+ ----------------
+ tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
+ tc_item (rep_ev_binds, rep_d) (sel_id, _)
+ = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+
+ ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+ meth_bind = VarBind { var_id = local_meth_id
+ , var_rhs = L loc meth_rhs
+ , var_inline = False }
+
+ bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+ , abs_exports = [(tyvars, meth_id,
+ local_meth_id, noSpecPrags)]
+ , abs_ev_binds = rep_ev_binds
+ , abs_binds = unitBag $ L loc meth_bind }
+
+ ; return (meth_id, L loc bind) }
+
+ ----------------
+ mk_op_wrapper :: Id -> EvVar -> HsWrapper
+ mk_op_wrapper sel_id rep_d
+ = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+ <.> WpEvApp (EvId rep_d)
+ <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
+ where
+ (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
+ (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
+ `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
+
+----------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+ = do { uniq <- newUnique
+ ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+ ; local_meth_name <- newLocalName sel_name
+ -- Base the local_meth_name on the selector name, becuase
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let meth_id = mkLocalId meth_name meth_ty
+ local_meth_id = mkLocalId local_meth_name local_meth_ty
+ ; return (meth_id, local_meth_id) }
where
+ local_meth_ty = instantiateMethod clas sel_id inst_tys
+ meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
+ sel_name = idName sel_id
+
+----------------------
+wrapId :: HsWrapper -> id -> HsExpr id
+wrapId wrapper id = mkHsWrap wrapper (HsVar id)
+
+derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt sel_id clas tys _bind
+ = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
+ , nest 2 (ptext (sLit "in a standalone derived instance for")
+ <+> quotes (pprClassPred clas tys) <> colon)
+ , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
+
+-- Too voluminous
+-- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+
+warnMissingMethod :: Id -> TcM ()
+warnMissingMethod sel_id
+ = do { warn <- doptM Opt_WarnMissingMethods
+ ; warnTc (warn -- Warn only if -fwarn-missing-methods
+ && not (startsWithUnderscore (getOccName sel_id)))
+ -- Don't warn about _foo methods
+ (ptext (sLit "No explicit method nor default method for")
+ <+> quotes (ppr sel_id)) }
+\end{code}
- -----------------------
- -- make_wrapper
- -- We distinguish two cases:
- -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
- -- and the new dict can just be a constant
- -- (mb_preds = Just preds)
- -- (b) there are tyvars, so we must make a dict *fun*
- -- (mb_preds = Nothing)
- -- See the defn of NewTypeDerived for the meaning of mb_preds
- make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
- = ASSERT( null tvs && null theta )
- do { dicts <- newDictBndrs inst_loc preds
- ; extendLIEs dicts
- ; return (map instToId dicts, idCoercion) }
- make_wrapper inst_loc tvs theta Nothing -- Case (b)
- = do { dicts <- newDictBndrs inst_loc theta
- ; let dict_ids = map instToId dicts
- ; return (dict_ids, mkCoTyLams tvs <.> mkCoLams dict_ids) }
-
- -----------------------
- -- make_coercion
- -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
- -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
- -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
- -- where rep_ty is the (eta-reduced) type rep of T
- -- So we just replace T with CoT, and insert a 'sym'
- -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
-
- make_coercion cls cls_inst_tys
- | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
- , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail
- , Just co_con <- newTyConCo_maybe tycon
- , let co = mkSymCoercion (mkTyConApp co_con tc_args)
- = ExprCoFn (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
- | otherwise -- The newtype is transparent; no need for a cast
- = idCoercion
- where
- cls_tycon = classTyCon cls
-
- -----------------------
- -- make_body
- -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
- -- (a) no superclasses; then we can just use the coerced dict
- -- (b) one or more superclasses; then new need to do the unpack/repack
-
- make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict
- | null sc_dict_ids -- Case (a)
- = return coerced_rep_dict
- | otherwise -- Case (b)
- = do { op_ids <- newSysLocalIds FSLIT("op") op_tys
- ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
- ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
- pat_dicts = dummy_sc_dict_ids,
- pat_binds = emptyLHsBinds,
- pat_args = PrefixCon (map nlVarPat op_ids),
- pat_ty = inst_head_ty}
- the_match = mkSimpleMatch [noLoc the_pat] the_rhs
- the_rhs = mkHsConApp cls_data_con cls_inst_tys $
- map HsVar (sc_dict_ids ++ op_ids)
-
- -- Warning: this HsCase scrutinises a value with a PredTy, which is
- -- never otherwise seen in Haskell source code. It'd be
- -- nicer to generate Core directly!
- ; return (HsCase (noLoc coerced_rep_dict) $
- MatchGroup [the_match] (mkFunTy inst_head_ty inst_head_ty)) }
- where
- cls_data_con = classDataCon cls
- cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
- op_tys = dropList sc_dict_ids cls_arg_tys
-
-------------------------
--- Ordinary instances
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
- = let
- dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
- inst_ty = idType dfun_id
- in
- -- Prime error recovery
- recoverM (returnM emptyLHsBinds) $
- setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
- addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-
- -- Instantiate the instance decl with skolem constants
- tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
- -- These inst_tyvars' scope over the 'where' part
- -- Those tyvars are inside the dfun_id's type, which is a bit
- -- bizarre, but OK so long as you realise it!
- let
- (clas, inst_tys') = tcSplitDFunHead inst_head'
- (class_tyvars, sc_theta, _, op_items) = classBigSig clas
-
- -- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
- origin = SigOrigin rigid_info
- in
- -- Create dictionary Ids from the specified instance contexts.
- getInstLoc InstScOrigin `thenM` \ sc_loc ->
- newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts ->
- getInstLoc origin `thenM` \ inst_loc ->
- newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_dicts ->
- newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict ->
- -- Default-method Ids may be mentioned in synthesised RHSs,
- -- but they'll already be in the environment.
-
- -- Typecheck the methods
- let -- These insts are in scope; quite a few, eh?
- avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
- in
- tcMethods origin clas inst_tyvars'
- dfun_theta' inst_tys' avail_insts
- op_items monobinds uprags `thenM` \ (meth_ids, meth_binds) ->
-
- -- Figure out bindings for the superclass context
- -- Don't include this_dict in the 'givens', else
- -- sc_dicts get bound by just selecting from this_dict!!
- addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_tyvars'
- dfun_arg_dicts
- sc_dicts) `thenM` \ sc_binds ->
-
- -- It's possible that the superclass stuff might unified one
- -- of the inst_tyavars' with something in the envt
- checkSigTyVars inst_tyvars' `thenM_`
-
- -- Deal with 'SPECIALISE instance' pragmas
- tcPrags dfun_id (filter isSpecInstLSig uprags) `thenM` \ prags ->
-
- -- Create the result bindings
- let
- dict_constr = classDataCon clas
- scs_and_meths = map instToId sc_dicts ++ meth_ids
- this_dict_id = instToId this_dict
- inline_prag | null dfun_arg_dicts = []
- | otherwise = [InlinePrag (Inline AlwaysActive True)]
- -- Always inline the dfun; this is an experimental decision
- -- because it makes a big performance difference sometimes.
- -- Often it means we can do the method selection, and then
- -- inline the method as well. Marcin's idea; see comments below.
- --
- -- BUT: don't inline it if it's a constant dictionary;
- -- we'll get all the benefit without inlining, and we get
- -- a **lot** of code duplication if we inline it
- --
- -- See Note [Inline dfuns] below
-
- dict_rhs
- = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
- -- We don't produce a binding for the dict_constr; instead we
- -- rely on the simplifier to unfold this saturated application
- -- We do this rather than generate an HsCon directly, because
- -- it means that the special cases (e.g. dictionary with only one
- -- member) are dealt with by the common MkId.mkDataConWrapId code rather
- -- than needing to be repeated here.
-
- dict_bind = noLoc (VarBind this_dict_id dict_rhs)
- all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
-
- main_bind = noLoc $ AbsBinds
- inst_tyvars'
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', dfun_id, this_dict_id,
- inline_prag ++ prags)]
- all_binds
- in
- showLIE (text "instance") `thenM_`
- returnM (unitBag main_bind)
-
-
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- avail_insts op_items monobinds uprags
- = -- Check that all the method bindings come from this class
- let
- sel_names = [idName sel_id | (sel_id, _) <- op_items]
- bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
- in
- mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
-
- -- Make the method bindings
- let
- mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
- in
- mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) ->
-
- -- And type check them
- -- It's really worth making meth_insts available to the tcMethodBind
- -- Consider instance Monad (ST s) where
- -- {-# INLINE (>>) #-}
- -- (>>) = ...(>>=)...
- -- If we don't include meth_insts, we end up with bindings like this:
- -- rec { dict = MkD then bind ...
- -- then = inline_me (... (GHC.Base.>>= dict) ...)
- -- bind = ... }
- -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
- -- and (b) the inline_me prevents us inlining the >>= selector, which
- -- would unravel the loop. Result: (>>) ends up as a loop breaker, and
- -- is not inlined across modules. Rather ironic since this does not
- -- happen without the INLINE pragma!
- --
- -- Solution: make meth_insts available, so that 'then' refers directly
- -- to the local 'bind' rather than going via the dictionary.
- --
- -- BUT WATCH OUT! If the method type mentions the class variable, then
- -- this optimisation is not right. Consider
- -- class C a where
- -- op :: Eq a => a
- --
- -- instance C Int where
- -- op = op
- -- The occurrence of 'op' on the rhs gives rise to a constraint
- -- op at Int
- -- The trouble is that the 'meth_inst' for op, which is 'available', also
- -- looks like 'op at Int'. But they are not the same.
- let
- prag_fn = mkPragFun uprags
- all_insts = avail_insts ++ catMaybes meth_insts
- sig_fn n = Just [] -- No scoped type variables, but every method has
- -- a type signature, in effect, so that we check
- -- the method has the right type
- tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
- meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
- in
-
- mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+ class Baz v x where
+ foo :: x -> x
+ foo y = <blah>
+
+ instance Baz Int Int
+
+From the class decl we get
+
+ $dmfoo :: forall v x. Baz v x => x -> x
+ $dmfoo y = <blah>
+
+Notice that the type is ambiguous. That's fine, though. The instance
+decl generates
+
+ $dBazIntInt = MkBaz fooIntInt
+ fooIntInt = $dmfoo Int Int $dBazIntInt
+
+BUT this does mean we must generate the dictionary translation of
+fooIntInt directly, rather than generating source-code and
+type-checking it. That was the bug in Trac #1061. In any case it's
+less work to generate the translated version!
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Default methods need special case. They are supposed to behave rather like
+macros. For exmample
+
+ class Foo a where
+ op1, op2 :: Bool -> a -> a
+
+ {-# INLINE op1 #-}
+ op1 b x = op2 (not b) x
+
+ instance Foo Int where
+ -- op1 via default method
+ op2 b x = <blah>
- returnM (meth_ids, unionManyBags meth_binds_s)
-\end{code}
+The instance declaration should behave
+
+ just as if 'op1' had been defined with the
+ code, and INLINE pragma, from its original
+ definition.
+
+That is, just as if you'd written
+
+ instance Foo Int where
+ op2 b x = <blah>
+
+ {-# INLINE op1 #-}
+ op1 b x = op2 (not b) x
+
+So for the above example we generate:
+
+
+ {-# INLINE $dmop1 #-}
+ -- $dmop1 has an InlineCompulsory unfolding
+ $dmop1 d b x = op2 d (not b) x
+ $fFooInt = MkD $cop1 $cop2
- ------------------------------
- [Inline dfuns] Inlining dfuns unconditionally
- ------------------------------
-
-The code above unconditionally inlines dict funs. Here's why.
-Consider this program:
-
- test :: Int -> Int -> Bool
- test x y = (x,y) == (y,x) || test y x
- -- Recursive to avoid making it inline.
-
-This needs the (Eq (Int,Int)) instance. If we inline that dfun
-the code we end up with is good:
-
- Test.$wtest =
- \r -> case ==# [ww ww1] of wild {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True ->
- case ==# [ww1 ww] of wild1 {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True -> PrelBase.True [];
- };
- };
- Test.test = \r [w w1]
- case w of w2 {
- PrelBase.I# ww ->
- case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
- };
-
-If we don't inline the dfun, the code is not nearly as good:
-
- (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
- PrelBase.:DEq tpl1 tpl2 -> tpl2;
- };
-
- Test.$wtest =
- \r [ww ww1]
- let { y = PrelBase.I#! [ww1]; } in
- let { x = PrelBase.I#! [ww]; } in
- let { sat_slx = PrelTup.(,)! [y x]; } in
- let { sat_sly = PrelTup.(,)! [x y];
- } in
- case == sat_sly sat_slx of wild {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True -> PrelBase.True [];
- };
-
- Test.test =
- \r [w w1]
- case w of w2 {
- PrelBase.I# ww ->
- case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
- };
-
-Why doesn't GHC inline $fEq? Because it looks big:
-
- PrelTup.zdfEqZ1T{-rcX-}
- = \ @ a{-reT-} :: * @ b{-reS-} :: *
- zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
- zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
- let {
- zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
- zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
- let {
- zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
- zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
- let {
- zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
- zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
- ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
- case ds{-rf5-}
- of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
- case ds1{-rf4-}
- of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
- PrelBase.zaza{-r4e-}
- (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
- (zeze{-rf0-} a2{-reZ-} b2{-reY-})
- }
- } } in
- let {
- a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
- a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
- b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
- PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
- } in
- PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
-
-and it's not as bad as it seems, because it's further dramatically
-simplified: only zeze2 is extracted and its body is simplified.
+ {-# INLINE $cop1 #-}
+ $cop1 = $dmop1 $fFooInt
+
+ $cop2 = <blah>
+
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+ instance $cop1. Otherwise we'll just inline the former in the
+ latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an
+ unfolding with an InlineCompulsory source. That means
+ that it'll be inlined at every use site, notably in
+ each instance declaration, such as $cop1. This inlining
+ must happen even though
+ a) $dmop1 is not saturated in $cop1
+ b) $cop1 itself has an INLINE pragma
+
+ It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+ recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+ (which makes the Unfoldings), we use the IsDefaultMethod constructor
+ in TcSpecPrags.
%************************************************************************
-%* *
+%* *
\subsection{Error messages}
-%* *
+%* *
%************************************************************************
\begin{code}
-instDeclCtxt1 hs_inst_ty
+instDeclCtxt1 :: LHsType Name -> SDoc
+instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (case unLoc hs_inst_ty of
- HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
- HsPredTy pred -> ppr pred
- other -> ppr hs_inst_ty) -- Don't expect this
+ HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
+ HsPredTy pred -> ppr pred
+ _ -> ppr hs_inst_ty) -- Don't expect this
+instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
(_,_,cls,tys) = tcSplitDFunTy dfun_ty
-inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
-
-superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
-atInstCtxt name = ptext SLIT("In the associated type instance for") <+>
- quotes (ppr name)
+atInstCtxt :: Name -> SDoc
+atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
+ quotes (ppr name)
-mustBeVarArgErr ty =
- sep [ ptext SLIT("Arguments that do not correspond to a class parameter") <+>
- ptext SLIT("must be variables")
- , ptext SLIT("Instead of a variable, found") <+> ppr ty
+mustBeVarArgErr :: Type -> SDoc
+mustBeVarArgErr ty =
+ sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
+ ptext (sLit "must be variables")
+ , ptext (sLit "Instead of a variable, found") <+> ppr ty
]
+wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
- sep [ ptext SLIT("Type indexes must match class instance head")
- , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>
- ppr instTy
+ sep [ ptext (sLit "Type indexes must match class instance head")
+ , ptext (sLit "Found") <+> quotes (ppr ty)
+ <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
\end{code}